tidy up router

seroanalytics · Sep 26, 2024 · 18bc08b · 18bc08b
1 parent e0760dc
commit 18bc08b
Show file tree

Hide file tree

Showing 3 changed files with 109 additions and 97 deletions.
diff --git a/R/router.R b/R/router.R
@@ -5,7 +5,37 @@ build_routes <- function(cookie_key = plumber::random_cookie_key(),
   }
   plumber::options_plumber(trailingSlash = TRUE)
   pr <- porcelain::porcelain$new(validate = TRUE)
-  pr$registerHook(stage = "preserialize", function(data, req, res, value) {
+  pr$registerHook(stage = "preserialize", preserialize_hook(cache))
+  pr$registerHooks(plumber::session_cookie(cookie_key,
+                                           name = "serovizr",
+                                           path = "/"))
+
+  pr$filter("logger", logging_filter)
+
+  pr$handle(get_root())
+  pr$handle(get_version())
+  # porcelain doesn't support multipart form content yet; for now wire this
+  # endpoint up using plumber arguments instead
+  pr$handle("POST", "/api/dataset/", target_post_dataset,
+            serializer = plumber::serializer_unboxed_json(null = "null"))
+  pr$handle(options_dataset())
+  pr$handle(delete_dataset())
+  pr$handle(get_dataset())
+  pr$handle(get_datasets())
+  pr$handle(get_trace())
+  pr$handle(get_individual())
+  setup_docs(pr)
+}
+
+logging_filter <- function(req, res) {
+  logger::log_info(paste(as.character(Sys.time()), "-",
+                         req$REQUEST_METHOD, req$PATH_INFO, "-",
+                         req$HTTP_USER_AGENT, "@", req$REMOTE_ADDR, "\n"))
+  plumber::forward()
+}
+
+preserialize_hook <- function(cache) {
+  function(data, req, res, value) {
     if (!is.null(req$HTTP_ORIGIN) &&
       req$HTTP_ORIGIN %in% c("http://localhost:3000", "http://localhost")) {
       # allow local app and integration tests to access endpoints
@@ -26,113 +56,23 @@ build_routes <- function(cookie_key = plumber::random_cookie_key(),
     }, error = function(e) logger::log_error(conditionMessage(e)))
 
     value
-  })
-
-  pr$registerHooks(plumber::session_cookie(cookie_key,
-                                           name = "serovizr",
-                                           path = "/"))
-
-  pr$filter("logger", function(req, res) {
-    logger::log_info(paste(as.character(Sys.time()), "-",
-                           req$REQUEST_METHOD, req$PATH_INFO, "-",
-                           req$HTTP_USER_AGENT, "@", req$REMOTE_ADDR, "\n"))
-    plumber::forward()
-  })
+  }
+}
 
-  pr$handle(get_root())
-  pr$handle(get_version())
-  pr$handle("POST", "/api/dataset/",
-            function(req, res) target_post_dataset(req, res),
-            serializer = plumber::serializer_unboxed_json(null = "null"))
-  pr$handle(options_dataset())
-  pr$handle(delete_dataset())
-  pr$handle(get_dataset())
-  pr$handle(get_datasets())
-  pr$handle(get_trace())
-  pr$handle(get_individual())
+setup_docs <- function(pr) {
   api <- yaml::read_yaml(file.path(system.file("spec.yaml",
                                                package = "serovizr")),
                          eval.expr = FALSE)
   pr$setApiSpec(api)
+  # this is a bit annoying, but setDocs fails if the package isn't
+  # already loaded
   library(redoc)
   pr$setDocs("redoc")
   pr$mount("/schema", plumber::PlumberStatic$new(file.path(system.file("schema",
-                                                   package = "serovizr"))))
+                                                                       package = "serovizr"))))
   pr
 }
 
-get_root <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET",
-    "/api/",
-    target_get_root,
-    returning = porcelain::porcelain_returning_json())
-}
-
-get_version <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET",
-    "/api/version/",
-    target_get_version,
-    returning = porcelain::porcelain_returning_json("Version"))
-}
-
-get_dataset <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET", "/api/dataset/<name>/",
-    target_get_dataset,
-    returning = porcelain::porcelain_returning_json("DatasetMetadata"))
-}
-
-delete_dataset <- function() {
-  porcelain::porcelain_endpoint$new(
-    "DELETE", "/api/dataset/<name>/",
-    target_delete_dataset,
-    returning = porcelain::porcelain_returning_json())
-}
-
-options_dataset <- function() {
-  porcelain::porcelain_endpoint$new(
-    "OPTIONS", "/api/dataset/<name>/",
-    function(name) "OK",
-    returning = porcelain::porcelain_returning_json())
-}
-
-get_datasets <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET",
-    "/api/datasets/",
-    target_get_datasets,
-    returning = porcelain::porcelain_returning_json("DatasetNames"))
-}
-
-get_trace <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET",
-    "/api/dataset/<name>/trace/<biomarker>/",
-    target_get_trace,
-    porcelain::porcelain_input_query(disaggregate = "string",
-                                     filter = "string",
-                                     scale = "string",
-                                     method = "string",
-                                     span = "numeric",
-                                     k = "numeric"),
-    returning = porcelain::porcelain_returning_json("DataSeries"))
-}
-
-get_individual <- function() {
-  porcelain::porcelain_endpoint$new(
-    "GET",
-    "/api/dataset/<name>/individual/<pidcol>/",
-    target_get_individual,
-    porcelain::porcelain_input_query(scale = "string",
-                                     color = "string",
-                                     filter = "string",
-                                     linetype = "string",
-                                     page = "numeric"),
-    returning = porcelain::porcelain_returning_json("Plotly"))
-}
-
 prune_inactive_sessions <- function(cache) {
   active_sessions <- cache$keys()
   subdirectories <- list.files("uploads")

diff --git a/R/routes.R b/R/routes.R
@@ -0,0 +1,71 @@
+get_root <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET",
+    "/api/",
+    target_get_root,
+    returning = porcelain::porcelain_returning_json())
+}
+
+get_version <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET",
+    "/api/version/",
+    target_get_version,
+    returning = porcelain::porcelain_returning_json("Version"))
+}
+
+get_dataset <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET", "/api/dataset/<name>/",
+    target_get_dataset,
+    returning = porcelain::porcelain_returning_json("DatasetMetadata"))
+}
+
+delete_dataset <- function() {
+  porcelain::porcelain_endpoint$new(
+    "DELETE", "/api/dataset/<name>/",
+    target_delete_dataset,
+    returning = porcelain::porcelain_returning_json())
+}
+
+options_dataset <- function() {
+  porcelain::porcelain_endpoint$new(
+    "OPTIONS", "/api/dataset/<name>/",
+    function(name) "OK",
+    returning = porcelain::porcelain_returning_json())
+}
+
+get_datasets <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET",
+    "/api/datasets/",
+    target_get_datasets,
+    returning = porcelain::porcelain_returning_json("DatasetNames"))
+}
+
+get_trace <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET",
+    "/api/dataset/<name>/trace/<biomarker>/",
+    target_get_trace,
+    porcelain::porcelain_input_query(disaggregate = "string",
+                                     filter = "string",
+                                     scale = "string",
+                                     method = "string",
+                                     span = "numeric",
+                                     k = "numeric"),
+    returning = porcelain::porcelain_returning_json("DataSeries"))
+}
+
+get_individual <- function() {
+  porcelain::porcelain_endpoint$new(
+    "GET",
+    "/api/dataset/<name>/individual/<pidcol>/",
+    target_get_individual,
+    porcelain::porcelain_input_query(scale = "string",
+                                     color = "string",
+                                     filter = "string",
+                                     linetype = "string",
+                                     page = "numeric"),
+    returning = porcelain::porcelain_returning_json("Plotly"))
+}
diff --git a/tests/testthat/test-router.R b/tests/testthat/test-router.R
@@ -64,6 +64,7 @@ test_that("DELETE /dataset returns 200 if dataset doesn't exist", {
                               "/dataset/testdataset/",
                               HTTP_COOKIE = cookie))
   expect_equal(res$status, 200)
+  body <- jsonlite::fromJSON(res$body)
   expect_equal(body$data, "testdataset")
 })