Merge pull request #2 from seroanalytics/i1

Add session cookie support
seroanalytics · Aug 29, 2024 · 446a12b · 446a12b
2 parents 88c4d14 + 35e4451
commit 446a12b
Show file tree

Hide file tree

Showing 10 changed files with 327 additions and 103 deletions.
diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml
@@ -28,7 +28,7 @@ jobs:
           needs: lint
 
       - name: Lint
-        run: lintr::lint_package()
+        run: lintr::lint_dir("R")
         shell: Rscript {0}
         env:
           LINTR_ERROR_ON_LINT: true
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -9,7 +9,9 @@ License: GPL (>= 3)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
-Imports: 
+Imports:
+    base64enc,
+    cachem,
     docopt,
     jsonlite,
     logger,
@@ -20,7 +22,7 @@ Imports:
     stringr,
     tibble
 Remotes:
-    reside-ic/porcelain,
+    hillalex/porcelain@i39,
 Suggests:
     fs,
     lintr (>= 3.1.2),

diff --git a/R/api.R b/R/api.R
@@ -1,12 +1,15 @@
-target_get_root <- function() {
+target_get_root <- function(req) {
+  get_or_create_session_id(req)
   jsonlite::unbox("Welcome to serovizr")
 }
 
-target_get_version <- function() {
+target_get_version <- function(req) {
+  get_or_create_session_id(req)
   jsonlite::unbox(as.character(utils::packageVersion("serovizr")))
 }
 
 target_post_dataset <- function(req, res) {
+  session_id <- get_or_create_session_id(req)
   logger::log_info("Parsing multipart form request")
   parsed <- mime::parse_multipart(req)
   xcol <- parsed$xcol
@@ -27,8 +30,8 @@ target_post_dataset <- function(req, res) {
     filename <- stringr::str_remove_all(filename,
                                         paste0(".", file_ext))
   }
-  path <- file.path("uploads", filename)
-  if (file.exists(path)) {
+  path <- file.path("uploads", session_id, filename)
+  if (dir.exists(path)) {
     res$status <- 400L
     msg <- paste(filename, "already exists.",
                  "Please choose a unique name for this dataset.")
@@ -39,20 +42,20 @@ target_post_dataset <- function(req, res) {
   if (length(missing_cols) > 0) {
     res$status <- 400L
     msg <- paste("Missing required columns:",
-                                 paste(missing_cols, collapse = ", "))
+                 paste(missing_cols, collapse = ", "))
     return(bad_request_response(msg))
   }
 
   logger::log_info(paste("Saving dataset", filename, "to disk"))
-  dir.create(path)
+  dir.create(path, recursive = TRUE)
   utils::write.csv(file_body, file.path(path, "data"), row.names = FALSE)
   write(xcol, file.path(path, "xcol"))
   porcelain:::response_success(jsonlite::unbox(filename))
 }
 
-target_get_dataset <- function(name) {
+target_get_dataset <- function(name, req) {
   logger::log_info(paste("Requesting metadata for dataset:", name))
-  dataset <- read_dataset(name)
+  dataset <- read_dataset(req, name)
   logger::log_info(paste("Found dataset:", name))
   dat <- dataset$data
   xcol <- dataset$xcol
@@ -78,29 +81,31 @@ target_get_dataset <- function(name) {
        xcol = jsonlite::unbox(xcol))
 }
 
-target_get_datasets <- function() {
-  list.files("uploads")
+target_get_datasets <- function(req) {
+  session_id <- get_or_create_session_id(req)
+  list.files(file.path("uploads", session_id))
 }
 
 target_get_trace <- function(name,
                              biomarker,
+                             req,
                              filter = NULL,
                              disaggregate = NULL) {
   logger::log_info(paste("Requesting data from", name,
                          "with biomarker", biomarker))
-  dataset <- read_dataset(name)
+  dataset <- read_dataset(req, name)
   dat <- dataset$data
   xcol <- dataset$xcol
   cols <- colnames(dat)
   if (!is.null(filter)) {
     filters <- strsplit(filter, "+", fixed = TRUE)[[1]]
     logger::log_info(paste("Filtering by variables:", paste(filters,
                                                             collapse = ", ")))
-   for (f in filters) {
-     dat <- apply_filter(f, dat, cols)
-   }
+    for (f in filters) {
+      dat <- apply_filter(f, dat, cols)
+    }
   }
-  dat <- dat[dat["biomarker"] == biomarker,]
+  dat <- dat[dat["biomarker"] == biomarker, ]
   if (length(disaggregate) > 0) {
     logger::log_info(paste("Disaggregating by variables:", disaggregate))
     groups <- split(dat, eval(parse(text = paste("~", disaggregate))))
@@ -123,8 +128,9 @@ target_get_trace <- function(name,
   }
 }
 
-read_dataset <- function(name) {
-  path <- file.path("uploads", name)
+read_dataset <- function(req, name) {
+  session_id <- get_or_create_session_id(req)
+  path <- file.path("uploads", session_id, name)
   if (!file.exists(path)) {
     porcelain::porcelain_stop(paste("Did not find dataset with name:", name),
                               code = "DATASET_NOT_FOUND", status_code = 404L)
@@ -167,11 +173,28 @@ apply_filter <- function(filter, dat, cols) {
                                     "not found in data"),
                               code = "BAD_REQUEST", status_code = 400L)
   }
-  dat[dat[filter_var] == filter_level,]
+  dat[dat[filter_var] == filter_level, ]
 }
 
 bad_request_response <- function(msg) {
   error <- list(error = "BAD_REQUEST",
                 detail = msg)
   return(list(status = "failure", errors = list(error), data = NULL))
 }
+
+get_or_create_session_id <- function(req) {
+  if (is.null(req$session$id)) {
+    logger::log_info("Creating new session id")
+    req$session$id <- generate_session_id()
+  }
+  as.character(req$session$id)
+}
+
+generate_session_id <- function() {
+  tolower(rawToChar(sample(c(as.raw(sample(c(65:90, 97:122),
+                                           5,
+                                           replace = TRUE)),
+                             as.raw(sample(48:57,
+                                           5,
+                                           replace = TRUE))))))
+}
diff --git a/R/router.R b/R/router.R
@@ -1,4 +1,5 @@
-build_routes <- function() {
+build_routes <- function(cookie_key = plumber::random_cookie_key(),
+                         cache = cachem::cache_mem(max_age = 60)) {
   if (!dir.exists("uploads")) {
     dir.create("uploads")
   }
@@ -9,10 +10,22 @@ build_routes <- function() {
       req$HTTP_ORIGIN %in% c("http://localhost:3000", "http://localhost")) {
       # allow local app and integration tests to access endpoints
       res$setHeader("Access-Control-Allow-Origin", req$HTTP_ORIGIN)
+      res$setHeader("Access-Control-Allow-Credentials", "true")
     }
+
+    if (!is.null(req$session$id)) {
+      id <- as.character(req$session$id)
+      cache$set(id, TRUE)
+    }
+    prune_inactive_sessions(cache)
     value
   })
 
+  pr$registerHooks(plumber::session_cookie(cookie_key,
+                                           name = "serovizr",
+                                           path = "/",
+                                           expiration = 60))
+
   pr$handle(get_root())
   pr$handle(get_version())
   pr$handle("POST", "/dataset/",
@@ -23,7 +36,6 @@ build_routes <- function() {
   pr$handle(get_trace())
 }
 
-
 get_root <- function() {
   porcelain::porcelain_endpoint$new(
     "GET",
@@ -64,3 +76,13 @@ get_trace <- function() {
                                      filter = "string"),
     returning = porcelain::porcelain_returning_json("DataSeries"))
 }
+
+prune_inactive_sessions <- function(cache) {
+  active_sessions <- cache$keys()
+  subdirectories <- list.files("uploads")
+  old_sessions <- setdiff(subdirectories, active_sessions)
+  if (length(old_sessions) > 0) {
+    logger::log_info("Cleaning up expired sessions")
+    lapply(old_sessions, function(x) fs::dir_delete(file.path("uploads", x)))
+  }
+}
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
@@ -1,9 +1,13 @@
-make_req <- function(verb = "GET", path = "/", qs = "", body = "", pr = NULL, ...) {
+make_req <- function(verb = "GET",
+                     path = "/",
+                     qs = "",
+                     body = "",
+                     pr = NULL,
+                     ...) {
   req <- as.environment(list(...))
   req$REQUEST_METHOD <- toupper(verb)
   req$PATH_INFO <- path
   req$QUERY_STRING <- qs
-
   if (is.character(body)) {
     body <- charToRaw(body)
   }
@@ -13,17 +17,19 @@ make_req <- function(verb = "GET", path = "/", qs = "", body = "", pr = NULL, ..
   req
 }
 
-local_add_dataset <- function(dat, name, env = parent.frame()) {
-  filepath <- file.path("uploads", name)
-  dir.create(filepath)
+local_add_dataset <- function(dat, name, session = session_id, env = parent.frame()) {
+  filepath <- file.path("uploads", session, name)
+  dir.create(filepath, recursive = TRUE)
   write.csv(dat, file.path(filepath, "data"), row.names = FALSE)
   write("day", file.path(filepath, "xcol"))
   withr::defer(fs::dir_delete(filepath), envir = env)
   name
 }
 
 local_POST_dataset_request <- function(dat, filename, xcol = "day",
-                                       env = parent.frame()) {
+                                       env = parent.frame(),
+                                       session = session_id,
+                                       cookie = "") {
   EOL <- "\r\n"
   boundary <- "------WebKitFormBoundaryvbfCGA1r00d8B0Vv"
   request_body <- paste0(boundary, EOL,
@@ -35,7 +41,7 @@ local_POST_dataset_request <- function(dat, filename, xcol = "day",
                          "Content-Disposition: form-data; name=\"xcol\"", EOL, EOL,
                          xcol, EOL,
                          boundary, "--")
-  filepath <- file.path("uploads", filename)
+  filepath <- file.path("uploads", session, filename)
   withr::defer({
     if (fs::file_exists(filepath)) {
       fs::file_delete(filepath)
@@ -44,12 +50,13 @@ local_POST_dataset_request <- function(dat, filename, xcol = "day",
 
   make_req("POST", "/dataset/",
            body = request_body,
+           HTTP_COOKIE = cookie,
            CONTENT_LENGTH = nchar(request_body),
            CONTENT_TYPE = "multipart/form-data; boundary=----WebKitFormBoundaryvbfCGA1r00d8B0Vv")
 }
 
 local_POST_dataset_request_no_xcol <- function(dat, filename,
-                                       env = parent.frame()) {
+                                               env = parent.frame()) {
   EOL <- "\r\n"
   boundary <- "------WebKitFormBoundaryvbfCGA1r00d8B0Vv"
   request_body <- paste0(boundary, EOL,
@@ -58,7 +65,7 @@ local_POST_dataset_request_no_xcol <- function(dat, filename,
                          "Content-Type: text/csv", EOL, EOL,
                          readr::format_csv(dat, eol = EOL), EOL,
                          boundary, "--")
-  filepath <- file.path("uploads", filename)
+  filepath <- file.path("uploads", session_id, filename)
   withr::defer({
     if (fs::file_exists(filepath)) {
       fs::file_delete(filepath)
@@ -84,7 +91,7 @@ local_POST_dataset_request_bad_file <- function(env = parent.frame()) {
                          "Content-Disposition: form-data; name=\"xcol\"", EOL, EOL,
                          "day", EOL,
                          boundary, "--")
-  filepath <- file.path("uploads", filename)
+  filepath <- file.path("uploads", session_id, filename)
   withr::defer({
     if (fs::file_exists(filepath)) {
       fs::file_delete(filepath)

diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R
@@ -1,7 +1,13 @@
 # Run before any test
+set.seed(1)
 dir.create("uploads")
+schema_root <- file.path(system.file("schema", package = "serovizr"))
+session_id <- generate_session_id()
+cookie_key <- plumber::random_cookie_key()
+session <- list(id = session_id)
+encoded_cookie_val <- plumber:::encodeCookie(session,
+                                             plumber:::asCookieKey(cookie_key))
+cookie <- plumber:::cookieToStr("serovizr", encoded_cookie_val)
 
 # Run after all tests
 withr::defer(fs::dir_delete("uploads"), teardown_env())
-
-schema_root <- file.path(system.file("schema", package = "serovizr"))