Add router modifier tag support (#' @plumber) (#568)

Co-authored-by: Bruno Tremblay <meztez@neoxone.com>
Co-authored-by: Barret Schloerke <barret@rstudio.com>
Co-authored-by: Carson Sievert <cpsievert1@gmail.com>

NEWS.md

@@ -36,6 +36,8 @@ plumber 1.0.0
 
 * Added support for promises in endpoints, filters, and hooks. (#248)
 
+* Add support for `#' @plumber` tag to gain programmatic access to the `plumber` router via `function(pr) {....}`. (@meztez and @blairj09, #568)
+
 * Added Swagger support for array parameters using syntax `name:[type]` and new type `list` (synonym df, data.frame). (@meztez, #532)
 
 * Added support to a router's run method to allow the `swagger` parameter to be a function that

R/plumb-block.R

@@ -24,6 +24,7 @@ plumbBlock <- function(lineNum, file){
   comments <- ""
   responses <- NULL
   tags <- NULL
+  routerModifier <- NULL
   while (lineNum > 0 && (stri_detect_regex(file[lineNum], pattern="^#['\\*]") || stri_trim_both(file[lineNum]) == "")){
 
     line <- file[lineNum]
@@ -207,6 +208,11 @@ plumbBlock <- function(lineNum, file){
       comments <- paste(comments, commentMat[1,2])
     }
 
+    routerModifierMat <- stri_match(line, regex="^#['\\*]\\s*@plumber")
+    if (!is.na(routerModifierMat[1,1])) {
+      routerModifier <- TRUE
+    }
+
     lineNum <- lineNum - 1
   }
 
@@ -221,20 +227,21 @@ plumbBlock <- function(lineNum, file){
     params = rev(params),
     comments = comments,
     responses = responses,
-    tags = tags
+    tags = tags,
+    routerModifier = routerModifier
   )
 }
 
 #' Evaluate and activate a "block" of code found in a plumber API file.
 #' @include images.R
 #' @noRd
-evaluateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, mount) {
+evaluateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, pr) {
   lineNum <- srcref[1] - 1
 
   block <- plumbBlock(lineNum, file)
 
-  if (sum(!is.null(block$filter), !is.null(block$paths), !is.null(block$assets)) > 1){
-    stopOnLine(lineNum, file[lineNum], "A single function can only be a filter, an API endpoint, or an asset (@filter AND @get, @post, @assets, etc.)")
+  if (sum(!is.null(block$filter), !is.null(block$paths), !is.null(block$assets), !is.null(block$routerModifier)) > 1){
+    stopOnLine(lineNum, file[lineNum], "A single function can only be a filter, an API endpoint, an asset or a router modifier (@filter AND @get, @post, @assets, @plumber, etc.)")
   }
 
   # ALL if statements possibilities must eventually call eval(expr, envir)
@@ -279,10 +286,18 @@ evaluateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, mou
     }
 
     stat <- PlumberStatic$new(block$assets$dir, expr)
-    mount(path, stat)
-
+    pr$mount(path, stat)
+
+  } else if (!is.null(block$routerModifier)) {
+    if (is.expression(expr)){
+      func <- eval(expr, envir)
+      if (is.function(func)) {
+        func(pr)
+        return()
+      }
+    }
+    stopOnLine(lineNum, file[lineNum], "Invalid expression for @plumber tag, please use the form `function(pr) { }`.")
   } else {
-
     eval(expr, envir)
   }
 }

R/plumber.R

@@ -240,7 +240,7 @@ plumber <- R6Class(
           srcref <- attr(e, "srcref")[[1]][c(1,3)]
 
           evaluateBlock(srcref, private$lines, e, private$envir, private$addEndpointInternal,
-                        private$addFilterInternal, self$mount)
+                        private$addFilterInternal, self)
         }
 
         private$globalSettings <- plumbGlobals(private$lines)

tests/testthat/files/router-modifier.R

@@ -0,0 +1,4 @@
+#* @plumber
+function(pr){
+  pr$handle("GET", "/avatartare", function(raw) {raw}, serializer = serializer_json)
+}

tests/testthat/test-router-modifier.R

@@ -0,0 +1,7 @@
+context("Router modifier (@plumber tag)")
+
+test_that("router modifier tag works correctly", {
+  pr <- plumber$new(test_path("files/router-modifier.R"))
+  expect_equal(class(pr$routes[[1]])[1], "PlumberEndpoint")
+  expect_equal(names(pr$routes), "avatartare")
+})