R/plugin-perf.R

In tjpalanca/webtools: Web Server Tools

#' @title Performance Tools Plugin
#'
#' @description
#' Provide a set of utilities to profile handling. You can profile or benchmark
#' specific routes, specific handlers within routes, or load test the whole
#' application itself.
#'
#' @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 message   (str) message glue string
#' @param binary    (flg) is the message a binary message?
#' @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 close     (flg) if this is not a route, then close the connection?
#'
#' @export
PerfPlugin <- R6Class(
  classname = "PerfPlugin",
  inherit = DispatchPlugin,
  public = list(

    #' @description Create a new `PerfPlugin`
    initialize = function() {
      super$initialize("perf")
    },

    #' @description Profile a request passed through the handler stacks, pass
    #'              route name in order to profile just a specific route.
    #' @param interval  (num) loop interval for profiling
    #' @param ...       (arg) additional arguments to [`fiery::fake_request()`]
    profile = function(path      = "/",
                       url       = NULL,
                       router    = NULL,
                       message   = NULL,
                       binary    = FALSE,
                       method    = "get",
                       base_path = "",
                       content   = "",
                       headers   = list(),
                       trust     = TRUE,
                       attach    = c("request", "message", "header"),
                       interval  = 0.005,
                       close     = TRUE,
                       ...) {

      assert_number(interval, lower = 0.005)
      attach <- match_arg(attach) %||% "request"
      assert_string(attach)
      assert_string(path)
      self$fire$build_routers()
      dispatcher <- private$dispatcher(
        router  = router,
        attach  = attach,
        request = private$fake_request(path, url, method, base_path,
                                       content, headers, trust, ...),
        binary  = binary,
        message = message,
        close   = close
      )

      profvis(dispatcher(), interval = interval)

    },

    #' @description Measure the times needed to run through handler stack, pass
    #'              route name in order to benchmark a specific route
    #' @param times (int) number of times to run the expression
    #' @param ...   (arg) additional arguments to [`fiery::fake_request()`]
    benchmark = function(path      = "/",
                         url       = NULL,
                         router    = NULL,
                         message   = NULL,
                         binary    = FALSE,
                         method    = "get",
                         base_path = "",
                         content   = "",
                         headers   = list(),
                         trust     = TRUE,
                         attach    = c("request", "message", "header"),
                         times     = 100L,
                         close     = TRUE,
                         ...) {

      assert_int(times, lower = 1L)
      attach <- match_arg(attach) %||% "request"
      assert_string(attach)
      assert_string(path)
      request <- private$fake_request(path, url, method, base_path,
                                      content, headers, trust, ...)
      self$fire$build_routers()

      dispatcher <- private$dispatcher(
        router  = router,
        attach  = attach,
        request = request,
        binary  = binary,
        message = message,
        close   = close
      )

      microbenchmark(dispatcher(), times = times)

    },

    #' @description
    #' Run a load test on the application; this works by spinning up the
    #' application on the main thread and running an RStudio job to do the
    #' load test.
    #' @param threads (int) number of threads being run
    #' @param loops   (int) number of times each thread will run a hit
    #' @param headers (lst) list of headers to send with the request
    #' @param body    (lst) list to send as body of request
    #' @param encode  (str) either "json" or "raw"
    #' @param ramp    (str) number of seconds before all threads are firing
    #' @param delay   (str) delay for each request from the load tester
    #' @param wait    (int) seconds to wait before starting load test
    load_test = function(path    = "/",
                         method  = "GET",
                         threads = future::availableCores() * 2L,
                         loops   = 64L,
                         headers = NULL,
                         body    = NULL,
                         encode  = c("raw", "json"),
                         ramp    = 0L,
                         delay   = 0L,
                         wait    = 0L) {

      # nocov start

      app_url <- str_remove(self$fire$url, "/$")
      title   <- glue("Load Testing: {app_url}")
      method  <- str_to_upper(method)
      report  <- pkg_temp("loadtests", format(Sys.time(), "%Y%m%d%H%M%S"))

      self$app$log("info", "Starting the application at {app_url}")
      self$app$lifecycle_start(block = FALSE)

      self$app$log("info", "Performing load test in a separate R process")
      job({
        Sys.sleep(wait)
        loadtest_results <- loadtest(
          url       = app_url,
          threads   = threads,
          loops     = loops,
          method    = method,
          headers   = headers,
          body      = body,
          encode    = encode,
          ramp_time = ramp,
          delay_per_request = delay
        )
        loadtest_report(loadtest_results, report)
        viewer(paste0(report, ".html"))
        export(loadtest_results)
      }, packages = c("job", "loadtest", "rstudioapi"), title = title)

      return(invisible(self$app))

      # nocov end

    }

  )
)