Use promise domain to manage graphics devices

NAMESPACE

@@ -15,6 +15,7 @@ export(do_forward)
 export(do_provision)
 export(do_remove_api)
 export(do_remove_forward)
+export(endpoint_serializer)
 export(forward)
 export(getCharacterSet)
 export(get_character_set)
@@ -97,6 +98,8 @@ export(validate_api_spec)
 import(R6)
 import(promises)
 import(stringi)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)
 importFrom(jsonlite,parse_json)
 importFrom(jsonlite,toJSON)
 importFrom(lifecycle,deprecated)

NEWS.md

@@ -5,7 +5,7 @@ plumber 1.0.0
 
 #### Plumber router
 
-* Added support for promises in endpoints, filters, and hooks.  This allows for multi-core execution when paired with `future`. See `plumb_api("plumber", "13-promises")` and `plumb_api("plumber", "14-future")` for an example implementation. (#248)
+* Added support for promises in endpoints, filters, and hooks.  This allows for multi-core execution when paired with `future`. See `plumb_api("plumber", "13-promises")` and `plumb_api("plumber", "14-future")` for example implementations. (#248)
 * Added a Tidy API for more natural usage with magrittr's `%>%`. For example, a plumber object can now be initiated and run with `pr() %>% pr_run(port = 8080)`. For more examples, see [here](https://www.rplumber.io/articles/programmatic-usage.html) (@blairj09, #590)
 
 * Added support for `#' @plumber` tag to gain programmatic access to the `plumber` router via `function(pr) {....}`. See `system.file("plumber/06-sessions/plumber.R", package = "plumber")` and how it adds cookie support from within `plumber.R`. (@meztez and @blairj09, #568)
@@ -173,6 +173,8 @@ plumber 1.0.0
 
 * Get more file extension content types using the `mime` package. (#660)
 
+* Endpoints that produce images within a `promises::promise()` will now use the expected graphics device. (#669)
+
 ### Bug fixes
 
 * Handle plus signs in URI as space characters instead of actual plus signs (@meztez, #618)

R/hookable.R

@@ -73,6 +73,32 @@ Hookable <- R6Class(
           )
         )
       )
+    },
+    # Some stages (aroundexec) use a continuation passing style instead of callback style.
+    # https://en.wikipedia.org/wiki/Continuation-passing_style
+    # https://expressjs.com/en/guide/using-middleware.html
+    runHooksAround = function(stage, args = list(), .next) {
+      stageHooks <- private$hooks[[stage]]
+
+      # Execute the specified (i) hook. If i == 0, execute the .next continuation.
+      execHook <- function(i, hookArgs) {
+        if (i == 0) {
+          do.call(.next, getRelevantArgs(hookArgs, func = .next))
+        } else {
+          # Need to pass continuation to the hook
+          hookArgs <- c(hookArgs, .next = nextHook(i - 1))
+          stageHook <- stageHooks[[i]]
+          do.call(stageHook, getRelevantArgs(hookArgs, func = stageHook))
+        }
+      }
+
+      nextHook <- function(i) {
+        function(...) {
+          execHook(i, list(...))
+        }
+      }
+
+      execHook(i = length(stageHooks), args)
     }
   )
 )

R/plumber-step.R

@@ -73,8 +73,10 @@ PlumberStep <- R6Class(
         private$runHooks("preexec", c(list(data = hookEnv), args_for_formal_matching()))
       }
       execStep <- function(...) {
-        relevant_args <- getRelevantArgs(args_for_formal_matching(), func = private$func)
-        do.call(private$func, relevant_args, envir = private$envir)
+        private$runHooksAround("aroundexec", args_for_formal_matching(), .next = function(...) {
+          relevant_args <- getRelevantArgs(list(...), func = private$func)
+          do.call(private$func, relevant_args, envir = private$envir)
+        })
       }
       postexecStep <- function(value, ...) {
         private$runHooks("postexec", c(list(data = hookEnv, value = value), args_for_formal_matching()))
@@ -95,7 +97,7 @@ PlumberStep <- R6Class(
     #' @description step hook registration method
     #' @param stage a character string.
     #' @param handler a step handler function.
-    registerHook = function(stage=c("preexec", "postexec"), handler){
+    registerHook = function(stage=c("preexec", "postexec", "aroundexec"), handler){
       stage <- match.arg(stage)
       super$registerHook(stage, handler)
     }

R/serializer.R

@@ -394,7 +394,7 @@ serializer_xml <- function() {
 
 #' Endpoint Serializer with Hooks
 #'
-#' This method allows serializers to return both `preexec` and `postexec` hooks in addition to a serializer.
+#' This method allows serializers to return `preexec`, `postexec`, and `aroundexec` (\lifecycle{experimental}) hooks in addition to a serializer.
 #' This is useful for graphics device serializers which need a `preexec` and `postexec` hook to capture the graphics output.
 #'
 #' `preexec` and `postexec` hooks happend directly before and after a route is executed.
@@ -403,19 +403,28 @@ serializer_xml <- function() {
 #' @param serializer Serializer method to be used.  This method should already have its initialization arguments applied.
 #' @param preexec_hook Function to be run directly before a [PlumberEndpoint] calls its route method.
 #' @param postexec_hook Function to be run directly after a [PlumberEndpoint] calls its route method.
+#' @param aroundexec_hook Function to be run around a [PlumberEndpoint] call. Must handle a `.next` argument to continue execution. \lifecycle{experimental}
 #'
+#' @export
 #' @examples
 #' # The definition of `serializer_device` returns
-#' # * `preexec`, `postexec` hooks
 #' # * a `serializer_content_type` serializer
+#' # * `aroundexec` hook
 #' print(serializer_device)
-endpoint_serializer <- function(serializer, preexec_hook = NULL, postexec_hook = NULL) {
+endpoint_serializer <- function(
+  serializer,
+  preexec_hook = NULL,
+  postexec_hook = NULL,
+  aroundexec_hook = NULL
+) {
+
   stopifnot(is.function(serializer))
   structure(
     list(
       serializer = serializer,
       preexec_hook = preexec_hook,
-      postexec_hook = postexec_hook
+      postexec_hook = postexec_hook,
+      aroundexec_hook = aroundexec_hook
     ),
     class = "plumber_endpoint_serializer"
   )
@@ -430,6 +439,9 @@ self_set_serializer <- function(self, serializer) {
     if (!is.null(serializer$postexec_hook)) {
       self$registerHook("postexec", serializer$postexec_hook)
     }
+    if (!is.null(serializer$aroundexec_hook)) {
+      self$registerHook("aroundexec", serializer$aroundexec_hook)
+    }
   } else {
     self$serializer <- serializer
   }
@@ -458,20 +470,51 @@ serializer_device <- function(type, dev_on, dev_off = grDevices::dev.off) {
 
   endpoint_serializer(
     serializer = serializer_content_type(type),
-    preexec_hook = function(req, res, data) {
+    aroundexec_hook = function(..., .next) {
       tmpfile <- tempfile()
-      data$file <- tmpfile
 
       dev_on(filename = tmpfile)
-    },
-    postexec_hook = function(value, req, res, data) {
-      dev_off()
-
-      on.exit({unlink(data$file)}, add = TRUE)
-      con <- file(data$file, "rb")
-      on.exit({close(con)}, add = TRUE)
-      img <- readBin(con, "raw", file.info(data$file)$size)
-      img
+      device_id <- dev.cur()
+      dev_off_once <- once(function() dev_off(device_id))
+
+      success <- function(value) {
+        dev_off_once()
+        if (!file.exists(tmpfile)) {
+          stop("The device output file is missing. Did you produce an image?", call. = FALSE)
+        }
+        con <- file(tmpfile, "rb")
+        on.exit({close(con)}, add = TRUE)
+        img <- readBin(con, "raw", file.info(tmpfile)$size)
+        img
+      }
+
+      cleanup <- function() {
+        dev_off_once()
+        on.exit({
+          # works even if the file does not exist
+          unlink(tmpfile)
+        }, add = TRUE)
+      }
+
+      # This is just a flag to ensure we don't cleanup() if the .next(...) is
+      # async.
+      async <- FALSE
+
+      on.exit({
+        if (!async) {
+          cleanup()
+        }
+      }, add = TRUE)
+
+      result <- promises::with_promise_domain(createGraphicsDevicePromiseDomain(device_id), {
+        .next(...)
+      })
+      if (is.promising(result)) {
+        async <- TRUE
+        result %>% then(success) %>% finally(cleanup)
+      } else {
+        success(result)
+      }
     }
   )
 }
@@ -580,3 +623,55 @@ add_serializers_onLoad <- function() {
   ## Do not register until implemented
   # register_serializer("xml", serializer_xml)
 }
+
+# From https://github.com/rstudio/shiny/blob/ee13087d575d378fba2fae34664725dc7452df2d/R/imageutils.R
+#' @importFrom grDevices dev.set dev.cur
+# if the graphics device was not maintained for the promises, two promises could break how graphics are recorded
+## Bad
+## * Open p1 device
+## * Open p2 device
+## * Draw p1 in p2 device
+## * Draw p2 in p2 device
+## * Close cur device (p2)
+## * Close cur device (p1) (which is empty)
+##
+## Good (and implemented using the function below)
+## * Open p1 device in p1
+## * Open p2 device in p2
+## * Draw p1 in p1 device in p1
+## * Draw p2 in p2 device in p2
+## * Close p1 device in p1
+## * Close p2 device in p2
+createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
+  force(which)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      old <- dev.cur()
+      dev.set(which)
+      on.exit(dev.set(old))
+
+      force(expr)
+    }
+  )
+}

R/utils.R

@@ -28,3 +28,17 @@ is_available <- function (package, version = NULL) {
     x
   }
 }
+
+once <- function(f) {
+  called <- FALSE
+
+  function() {
+    if (!called) {
+      called <<- TRUE
+      f()
+      invisible(TRUE)
+    } else {
+      invisible(FALSE)
+    }
+  }
+}

R/validate_api_spec.R

@@ -49,7 +49,7 @@ validate_api_spec__install_node_modules <- function() {
 #'
 #' If the api is deemed invalid, an error will be thrown.
 #'
-#' This function is VERY experimental and may be altered, changed, or removed in the future.
+#' This function is VERY \lifecycle{experimental} and may be altered, changed, or removed in the future.
 #'
 #' @param pr A Plumber API
 #' @param verbose Logical that determines if a "is valid" statement is displayed. Defaults to `TRUE`

tests/testthat/files/async.R

@@ -54,3 +54,24 @@ function() {
 function() {
   1
 }
+
+
+#' @serializer png
+#' @get /promise_plot1
+function(n = 100) {
+  promises::promise_resolve(runif(n)) %...>%
+  {
+    dt <- .
+    hist(dt)
+  }
+}
+
+#' @serializer png
+#' @get /promise_plot2
+function(n = 100) {
+  promises::promise_resolve(runif(n)) %...>%
+  {
+    dt <- .
+    plot(dt)
+  }
+}