Add hybrid method for tutorial storage

NEWS.md

@@ -20,6 +20,7 @@ learnr (development version)
 * Previously, when a question submission was reset, it would be recorded as a `"question_submission"` event with the value `reset=TRUE`. Now it a separate event, `"reset_question_submission"`. ([#398](https://github.com/rstudio/learnr/pull/398))
 * Added a new `polyglot` tutorial to learnr. This tutorial displays mixing R, python, and sql exercises. See [`run_tutorial("polyglot", "learnr")`](https://learnr-examples.shinyapps.io/polyglot) for a an example. ([#397](https://github.com/rstudio/learnr/pull/397))
 * Text throughout the learnr interface can be customized or localized using the new `language` argument of `tutorial()`. Translations for English and French are provided and contributes will be welcomed. Read more about these features in `vignette("multilang", package = "learnr")`. ([#456](https://github.com/rstudio/learnr/pull/456), [#479](https://github.com/rstudio/learnr/pull/479))
+* Added a new storage helper function. Hybrid storage combines the client and filesystem storage methods by using the client's cookies to restore data when available, and turning to the filesystem when they are not. This combines the speed of restoring locally with the persistence of storing on a filesystem.
 
 ## Minor new features and improvements
 

R/storage.R

@@ -498,3 +498,175 @@ no_storage <- function() {
     remove_all_objects = function(tutorial_id, tutorial_version, user_id) {}
   )
 }
+
+# Storage for storing in browser and restoring from filesystem if cookies are cleared
+hybrid_storage <- function(session, dir, compress = TRUE) {
+
+  # helpers to transform ids into valid filesystem paths
+  id_to_filesystem_path <- function(id) {
+    id <- gsub("..", "", id, fixed = TRUE)
+    utils::URLencode(id, reserved = TRUE, repeated = TRUE)
+  }
+  id_from_filesystem_path <- function(path) {
+    utils::URLdecode(path)
+  }
+
+  # get the path to storage (ensuring that the directory exists)
+  storage_path <- function(tutorial_id, tutorial_version, user_id) {
+    path <- file.path(dir,
+                      id_to_filesystem_path(user_id),
+                      id_to_filesystem_path(tutorial_id),
+                      id_to_filesystem_path(tutorial_version))
+    if (!utils::file_test("-d", path))
+      dir.create(path, recursive = TRUE)
+    path
+  }
+
+  # helper to form a unique tutorial context id (note that we don't utilize the user_id
+  # as there is no concept of server-side user in client_storage, user scope is 100%
+  # determined by connecting user agent)
+  tutorial_context_id <- function(tutorial_id, tutorial_version) {
+    paste(tutorial_id, tutorial_version, sep = "-")
+  }
+
+  # get a reference to the session object cache for a gvien tutorial context
+  object_store <- function(context_id) {
+
+    # create session objects on demand
+    session_objects <- read_request(session, "tutorial.session_objects")
+    if (is.null(session_objects)) {
+      # MS Update: if the session object
+      session_objects <- new.env(parent = emptyenv())
+      write_request(session, "tutorial.session_objects", session_objects)
+    }
+
+    # create entry for this context on demand
+    if (!exists(context_id, envir = session_objects))
+      assign(context_id, new.env(parent = emptyenv()), envir = session_objects)
+    store <- get(context_id, envir = session_objects)
+
+    # return reference to the store
+    store
+  }
+
+  list(
+
+    type = "hybrid",
+
+    save_object = function(tutorial_id, tutorial_version, user_id, object_id, data, disk_write = TRUE) {
+
+      context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+      store <- object_store(context_id)
+      objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
+
+      assign(object_id, data, envir = store)
+
+      tryCatch({
+        # broadcast to client
+        session$sendCustomMessage("tutorial.store_object", list(
+          context = context_id,
+          id = object_id,
+          data = jsonlite::base64_enc(serialize(data, connection = NULL))
+        ))
+      }, error = function(e) {
+        warning(paste0("Error In client save broadcast", e))
+      })
+
+
+      # Save to disk storage
+      if(dir.exists(file.path(storage_path(tutorial_id, tutorial_version, user_id)))) {
+        object_path <- file.path(storage_path(tutorial_id, tutorial_version, user_id),
+                                 paste0(id_to_filesystem_path(object_id), ".rds"))
+        saveRDS(data, file = object_path, compress = compress)
+      }
+    },
+
+
+    get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
+      context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+      store <- object_store(context_id)
+      if (exists(object_id, envir = store))
+        get(object_id, envir = store)
+      else
+        NULL
+    },
+
+    get_objects = function(tutorial_id, tutorial_version, user_id) {
+      context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+      store <- object_store(context_id)
+      objects <- list()
+      objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
+
+      for(file in list.files(objects_path, pattern = utils::glob2rx("*.rds"))) {
+        obj_name <- tools::file_path_sans_ext(file)
+
+        # If item isn't in current store
+        if(!exists(obj_name, envir = store)) {
+
+          if(obj_name == client_state_object_id) next
+
+          objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
+          object <- readRDS(file.path(objects_path, file))
+          object_id <- sub("\\.rds$", "", id_from_filesystem_path(file))
+          objects[[length(objects) + 1]] <- object
+
+          # save the object to our in-memory store
+          context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+          store <- object_store(context_id)
+          assign(object_id, object, envir = store)
+
+          # broadcast to client
+          tryCatch({
+            session$sendCustomMessage("tutorial.store_object", list(
+              context = context_id,
+              id = object_id,
+              data = jsonlite::base64_enc(serialize(object, connection = NULL))
+            ))
+          }, error = function(e){
+            warning(paste0("Failed to restore Cookies", e))
+          })
+
+          # Item is found in current store
+        } else {
+          objects[[length(objects) + 1]] <- get(obj_name, envir = store)
+        }
+
+      }
+
+
+      objects
+    },
+
+    remove_all_objects = function(tutorial_id, tutorial_version, user_id) {
+      # remove on client side
+      tryCatch({
+        context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+        store <- object_store(context_id)
+        rm(list = ls(store), envir = store)
+
+      }, error = function(e) {
+        warning(paste0("Failed to remove client storage ", e))
+      })
+
+      # Remove on server side
+      tryCatch({
+        objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
+        unlink(objects_path, recursive = TRUE)
+      }, error = function(e){
+        warning("Failed to remove disk storage")
+      })
+
+    },
+
+    # function called from initialize to prime object storage from the browser db
+    initialize_objects_from_client = function(tutorial_id, tutorial_version, user_id, objects) {
+      print("Initializing from client")
+      context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+      store <- object_store(context_id)
+      for (object_id in names(objects)) {
+        data <- unserialize(base64_dec(objects[[object_id]]))
+        assign(object_id, data, envir = store)
+      }
+    }
+  )
+}

README.md

@@ -45,4 +45,4 @@ devtools::install_github("rstudio/packrat")
 `learnr` does not actively support IE11 and Edge.
 
 - [IE11 not receiving major updates](https://support.microsoft.com/en-us/help/17454/lifecycle-faq-internet-explorer), so I am not pursuing support for IE11.
-- [Edge is adopting chromium](https://blogs.windows.com/windowsexperience/2018/12/06/microsoft-edge-making-the-web-better-through-more-open-source-collaboration/). Once updated, Edge *should* work out of the box with many more R packages (including `learnr`) and websites.
+- [Edge is adopting chromium](https://blogs.windows.com/windowsexperience/2018/12/06/microsoft-edge-making-the-web-better-through-more-open-source-collaboration/). Once updated, Edge *should* work out of the box with many more R packages (including `learnr`) and websites.

tests/testthat/test-storage.R

@@ -12,4 +12,37 @@ test_that("objects cna be saved into filesystem storage", {
   obj <- fs$get_object("tutorial_id", "tutorial_version", "user_id", "object_id")
   expect_equal(obj, "data")
   fs$remove_all_objects("tutorial_id", "tutorial_version", "user_id")
-})
+})
+
+
+## Commented out because "testServer" can not test anyhting that uses 'session$request'
+
+# td <- tempdir()
+#
+# server <- function(input, output, session){}
+#
+# testServer(server, {
+#   hs <- hybrid_storage(session, td)
+#   context_id <- tutorial_context_id(tutorial_id, tutorial_version)
+#   store <- object_store(context_id)
+#
+#   hs$save_object("tutorial_id", "tutorial_version", "user_id", "object_id", "data")
+#
+#   # Object is saved in both locations
+#   stopifnot(length(list.files(td)) == 1)
+#   stopifnot(length(ls(store)) == 1)
+#   stopifnot(identical(
+#     hs$get_object("tutorial_id", "tutorial_version", "user_id", "object_id"),
+#     "data"
+#   ))
+#
+#   # Object is removed from cookies but is still present in filesystem
+#   client_storage(session)$remove_all_objects("tutorial_id", "tutorial_version", "user_id")
+#   stopifnot(length(ls(store)) == 0)
+#   stopifnot(length(list.files(td)) == 1)
+#
+#   # When objects are pulled in, they are also stored in
+#   objs <- hs$get_objects("tutorial_id", "tutorial_version", "user_id")
+#   stopifnot(identical(objs, list("data")))
+#   stopifnot(length(ls(store)) == 1)
+# })