From d5975195b3aed1fa6a9e6f7f36bd2e5df201878a Mon Sep 17 00:00:00 2001
From: Winston Chang <winston@stdout.org>
Date: Thu, 19 May 2016 17:06:53 -0500
Subject: [PATCH] Initial version of saving state

---
 DESCRIPTION                  |  1 +
 NAMESPACE                    |  2 ++
 R/app.R                      | 11 ++++++-
 R/persist.R                  | 62 ++++++++++++++++++++++++++++++++++++
 R/restore.R                  | 56 ++++++++++++++++++++------------
 R/utils.R                    |  6 ++++
 man/encodeBookmarkDataURL.Rd |  2 +-
 7 files changed, 118 insertions(+), 22 deletions(-)
 create mode 100644 R/persist.R

diff --git a/DESCRIPTION b/DESCRIPTION
index 1e3214180..becc6b4a7 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -126,6 +126,7 @@ Collate:
     'modal.R'
     'modules.R'
     'notifications.R'
+    'persist.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'
diff --git a/NAMESPACE b/NAMESPACE
index 4376b811f..f11f34418 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -143,6 +143,7 @@ export(pageWithSidebar)
 export(paneViewer)
 export(parseQueryString)
 export(passwordInput)
+export(persistValues)
 export(plotOutput)
 export(plotPNG)
 export(pre)
@@ -176,6 +177,7 @@ export(repeatable)
 export(req)
 export(restoreInput)
 export(restoreValue)
+export(restoreValues)
 export(runApp)
 export(runExample)
 export(runGadget)
diff --git a/R/app.R b/R/app.R
index 65ee7e35b..26364dbc5 100644
--- a/R/app.R
+++ b/R/app.R
@@ -99,6 +99,10 @@ shinyAppDir <- function(appDir, options=list()) {
   # affected by future changes to the path)
   appDir <- normalizePath(appDir, mustWork = TRUE)
 
+  # Store appDir in options so that we can find out where we are from within the
+  # app.
+  shinyOptions(appDir = appDir)
+
   if (file.exists.ci(appDir, "server.R")) {
     shinyAppDir_serverR(appDir, options = options)
   } else if (file.exists.ci(appDir, "app.R")) {
@@ -113,7 +117,12 @@ shinyAppDir <- function(appDir, options=list()) {
 #' @export
 shinyAppFile <- function(appFile, options=list()) {
   appFile <- normalizePath(appFile, mustWork = TRUE)
-  shinyAppDir_appR(basename(appFile), dirname(appFile), options = options)
+  appDir <- dirname(appFile)
+
+  # Store appDir in options so that we can find out where we are
+  shinyOptions(appDir = appDir)
+
+  shinyAppDir_appR(basename(appFile), appDir, options = options)
 }
 
 # This reads in an app dir in the case that there's a server.R (and ui.R/www)
diff --git a/R/persist.R b/R/persist.R
new file mode 100644
index 000000000..79363fcb8
--- /dev/null
+++ b/R/persist.R
@@ -0,0 +1,62 @@
+#' Store a list of values
+#'
+#' @param values A named list of values to persist.
+#'
+#' @return A unique ID of the persisted values.
+#' @export
+persistValues <- function(values, id, exclude = NULL) {
+  # Serialize values, either to directory, or to a database.
+  if (!is.list(values))
+    stop("`values` must be a list.")
+  if (anyUnnamed(values))
+    stop("All values must be named.")
+
+  persistFile <- file.path(persistentDir(), paste0(id, ".rds"))
+  saveRDS(values, persistFile)
+  id
+}
+
+
+#' Restore values
+#'
+#' @param id ID of a set of values to restore.
+#'
+#' @return A list of values that were persisted.
+#' @export
+restoreValues <- function(id) {
+  if (is.null(id))
+    stop("restoreValues requires an ID to restore.")
+
+  persistFile <- file.path(persistentDir(), paste0(id, ".rds"))
+
+  tryCatch({
+    readRDS(persistFile)
+  }, error = function(e) {
+    stop(safeError(paste0("Unable to restore saved state ", id)))
+  })
+}
+
+
+
+persistentDir <- function() {
+  # This can be set by the hosting environment, like Shiny Server
+  pdir <- getShinyOption('persistentDir', default = NULL)
+
+  if (is.character(pdir)) {
+    pdir
+  } else if (is.function(pdir)) {
+    pdir()
+  } else if (is.null(pdir)) {
+    # Try to persist in app's directory, or, if that's not available, in the
+    # current directory.
+    appdir <- getShinyOption("appDir", default = getwd())
+
+    pdir <- file.path(appdir, "shiny_persist")
+    if (!dirExists(pdir)) {
+      dir.create(pdir)
+    }
+
+    pdir
+  }
+}
+
diff --git a/R/restore.R b/R/restore.R
index 13e401c65..12d0c4a4f 100644
--- a/R/restore.R
+++ b/R/restore.R
@@ -1,23 +1,31 @@
 #' @export
 decodeBookmarkDataURL <- function(url) {
   values <- parseQueryString(url, nested = TRUE)
-  mapply(names(values), values, SIMPLIFY = FALSE,
-    FUN = function(name, value) {
-      tryCatch(
-        jsonlite::fromJSON(value),
-        error = function(e) {
-          stop("Failed to parse URL parameter \"", name, "\"")
-        }
-      )
-    }
-  )
+
+  # If we have a "_state_id" key, restore from persisted state and ignore other
+  # key/value pairs. If not, restore from key/value pairs in the query string.
+  if (!is.null(values[["_state_id"]]) && nzchar(values[["_state_id"]])) {
+    restoreValues(values[["_state_id"]])
+
+  } else {
+    mapply(names(values), values, SIMPLIFY = FALSE,
+      FUN = function(name, value) {
+        tryCatch(
+          jsonlite::fromJSON(value),
+          error = function(e) {
+            stop("Failed to parse URL parameter \"", name, "\"")
+          }
+        )
+      }
+    )
+  }
 }
 
 #' @param input The session's input object.
 #' @param exclude A character vector of input names that should not be
 #'   bookmarked.
 #' @export
-encodeBookmarkDataURL <- function(input, exclude = NULL) {
+encodeBookmarkDataURL <- function(input, exclude = NULL, persist = FALSE) {
   vals <- reactiveValuesToList(input)
   vals <- vals[setdiff(names(vals), exclude)]
 
@@ -26,20 +34,28 @@ encodeBookmarkDataURL <- function(input, exclude = NULL) {
   unserializable_idx <- vapply(names(vals), function(x) {
     identical(impl$getMeta(x, "shiny.serializable"), FALSE)
   }, FUN.VALUE = logical(1))
+
   vals <- vals[!unserializable_idx]
 
-  vals <- vapply(vals, function(x) {
-    toJSON(x, strict_atomic = FALSE)
-  }, character(1), USE.NAMES = TRUE)
+  if (persist) {
+    id <- persistValues(vals)
+    paste0("_state_id=", encodeURIComponent(id))
 
-  paste0(
-    encodeURIComponent(names(vals)),
-    "=",
-    encodeURIComponent(vals),
-    collapse = "&"
-  )
+  } else {
+    vals <- vapply(vals, function(x) {
+      toJSON(x, strict_atomic = FALSE)
+    }, character(1), USE.NAMES = TRUE)
+
+    paste0(
+      encodeURIComponent(names(vals)),
+      "=",
+      encodeURIComponent(vals),
+      collapse = "&"
+    )
+  }
 }
 
+
 # Restore context. This is basically a key-value store, except for one important
 # difference: When the user `get()`s a value, the value is marked as pending;
 # when `flushPending()` is called, those pending values are marked as used. When
diff --git a/R/utils.R b/R/utils.R
index 31952f0fa..9895202f9 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -250,6 +250,12 @@ find.file.ci <- function(...) {
   return(matches[1])
 }
 
+# The function base::dir.exists was added in R 3.2.0, but for backward
+# compatibility we need to add this function
+dirExists <- function(paths) {
+  file.exists(paths) & file.info(paths)$isdir
+}
+
 # Attempt to join a path and relative path, and turn the result into a
 # (normalized) absolute path. The result will only be returned if it is an
 # existing file/directory and is a descendant of dir.
diff --git a/man/encodeBookmarkDataURL.Rd b/man/encodeBookmarkDataURL.Rd
index 376b69f6c..2f063e09d 100644
--- a/man/encodeBookmarkDataURL.Rd
+++ b/man/encodeBookmarkDataURL.Rd
@@ -3,7 +3,7 @@
 \name{encodeBookmarkDataURL}
 \alias{encodeBookmarkDataURL}
 \usage{
-encodeBookmarkDataURL(input, exclude = NULL)
+encodeBookmarkDataURL(input, exclude = NULL, persist = FALSE)
 }
 \arguments{
 \item{input}{The session's input object.}