Implement arbitrary file downloads

DESCRIPTION

@@ -29,7 +29,7 @@ URL: https://github.com/rstudio/shiny, http://rstudio.github.com/shiny/tutorial
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
     'map.R'
-    'random.R'
+    'utils.R'
     'timer.R'
     'tags.R'
     'cache.R'

NAMESPACE

@@ -8,6 +8,9 @@ export(checkboxInput)
 export(code)
 export(conditionalPanel)
 export(div)
+export(downloadButton)
+export(downloadHandler)
+export(downloadLink)
 export(em)
 export(fileInput)
 export(h1)

R/bootstrap.R

@@ -793,3 +793,47 @@ htmlOutput <- function(outputId) {
 uiOutput <- function(outputId) {
   htmlOutput(outputId)
 }
+
+#' Create a download button or link
+#' 
+#' Use these functions to create a download button or link; when clicked, it 
+#' will initiate a browser download. The filename and contents are specified by 
+#' the corresponding \code{\link{downloadHandler}} defined in the server 
+#' function.
+#' 
+#' @examples
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(con) {
+#'     write.csv(data, con)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @aliases downloadLink
+#' @seealso downloadHandler
+#' @export
+downloadButton <- function(outputId, label="Download", class=NULL) {
+  tags$a(id=outputId,
+         class=paste(c('btn shiny-download-link', class), collapse=" "),
+         href='',
+         target='_blank',
+         label)
+}
+
+#' @rdname downloadButton
+#' @export
+downloadLink <- function(outputId, label="Download", class=NULL) {
+  tags$a(id=outputId,
+         class=paste(c('shiny-download-link', class), collapse=" "),
+         href='',
+         target='_blank',
+         label)
+}

R/map.R

@@ -28,6 +28,12 @@ Map <- setRefClass(
       assign(key, value, pos=.env, inherits=FALSE)
       return(value)
     },
+    mset = function(...) {
+      args <- list(...)
+      for (key in names(args))
+        set(key, args[[key]])
+      return()
+    },
     remove = function(key) {
       if (.self$containsKey(key)) {
         result <- .self$get(key)

R/shiny.R

@@ -23,6 +23,7 @@ ShinyApp <- setRefClass(
     session = 'Values',
     token = 'character',  # Used to identify this instance in URLs
     plots = 'Map',
+    downloads = 'Map',
     allowDataUriScheme = 'logical'
   ),
   methods = list(
@@ -191,21 +192,98 @@ ShinyApp <- setRefClass(
         return(httpResponse(400, 'text/html', '<h1>Bad Request</h1>'))
 
       if (matches[2] == 'plot') {
-        savedPlot <- plots$get(matches[3])
+        savedPlot <- plots$get(utils::URLdecode(matches[3]))
         if (is.null(savedPlot))
           return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
 
         return(httpResponse(200, savedPlot$contentType, savedPlot$data))
       }
 
+      if (matches[2] == 'download') {
+
+        # A bunch of ugliness here. Filenames can be dynamically generated by
+        # the user code, so we don't know what they'll be in advance. But the
+        # most reliable way to use non-ASCII filenames for downloads is to
+        # put the actual filename in the URL. So we will start with URLs in
+        # the form:
+        # 
+        #   /session/$TOKEN/download/$NAME
+        #
+        # When a request matching that pattern is received, we will calculate
+        # the filename and see if it's non-ASCII; if so, we'll redirect to
+        #
+        #   /session/$TOKEN/download/$NAME/$FILENAME
+        #
+        # And when that pattern is received, we will actually return the file.
+        # Note that this means the filename and contents could be determined
+        # a few moments apart from each other (an HTTP roundtrip basically),
+        # hopefully that won't be enough to matter for anyone.
+
+        dlmatches <- regmatches(matches[3],
+                                regexec("^([^/]+)(/[^/]+)?$",
+                                        matches[3]))[[1]]
+        dlname <- utils::URLdecode(dlmatches[2])
+        download <- downloads$get(dlname)
+        if (is.null(download))
+          return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
+
+        filename <- ifelse(is.function(download$filename),
+                           Context$new()$run(download$filename),
+                           download$filename)
+
+        # If the URL does not contain the filename, and the desired filename
+        # contains non-ASCII characters, then do a redirect with the desired
+        # name tacked on the end.
+        if (dlmatches[3] == '' && grepl('[^ -~]', filename)) {
+
+          return(httpResponse(302, 'text/html', '<h1>Found</h1>', c(
+            'Location' = sprintf('%s/%s',
+                                 utils::URLencode(dlname, TRUE),
+                                 utils::URLencode(filename, TRUE)),
+            'Cache-Control' = 'no-cache')))
+        }
+
+        tmpdata <- tempfile()
+        on.exit(unlink(tmpdata))
+        conn <- file(tmpdata, open = 'wb')
+        result <- try(Context$new()$run(function() { download$func(conn) }))
+        if (is(result, 'try-error')) {
+          return(httpResponse(500, 'text/plain', 
+                              attr(result, 'condition')$message))
+        }
+        close(conn)
+        return(httpResponse(
+          200,
+          download$contentType %OR% getContentType(tools::file_ext(filename)),
+          readBin(tmpdata, 'raw', n=file.info(tmpdata)$size),
+          c(
+            'Content-Disposition' = ifelse(
+              dlmatches[3] == '',
+              'attachment; filename="' %.% 
+                gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
+                '"',
+              'attachment'
+            ),
+            'Cache-Control'='no-cache')))
+      }
+
       return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
     },
     savePlot = function(name, data, contentType) {
       plots$set(name, list(data=data, contentType=contentType))
       return(sprintf('session/%s/plot/%s?%s',
-                     URLencode(token),
-                     URLencode(name),
+                     URLencode(token, TRUE),
+                     URLencode(name, TRUE),
                      createUniqueId(8)))
+    },
+    registerDownload = function(name, filename, contentType, func) {
+
+      downloads$set(name, list(filename = filename,
+                               contentType = contentType,
+                               func = func))
+      return(sprintf('session/%s/download/%s',
+                     URLencode(token, TRUE),
+                     URLencode(name, TRUE)))
     }
   )
 )
@@ -361,50 +439,7 @@ staticHandler <- function(root) {
       return(NULL)
 
     ext <- tools::file_ext(abs.path)
-    content.type <- switch(
-      ext,
-      html='text/html; charset=UTF-8',
-      htm='text/html; charset=UTF-8',
-      js='text/javascript',
-      css='text/css',
-      png='image/png',
-      jpg='image/jpeg',
-      jpeg='image/jpeg',
-      gif='image/gif',
-      svg='image/svg+xml',
-      txt='text/plain',
-      pdf='application/pdf',
-      ps='application/postscript',
-      xml='application/xml',
-      m3u='audio/x-mpegurl',
-      m4a='audio/mp4a-latm',
-      m4b='audio/mp4a-latm',
-      m4p='audio/mp4a-latm',
-      mp3='audio/mpeg',
-      wav='audio/x-wav',
-      m4u='video/vnd.mpegurl',
-      m4v='video/x-m4v',
-      mp4='video/mp4',
-      mpeg='video/mpeg',
-      mpg='video/mpeg',
-      avi='video/x-msvideo',
-      mov='video/quicktime',
-      ogg='application/ogg',
-      swf='application/x-shockwave-flash',
-      doc='application/msword',
-      xls='application/vnd.ms-excel',
-      ppt='application/vnd.ms-powerpoint',
-      xlsx='application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
-      xltx='application/vnd.openxmlformats-officedocument.spreadsheetml.template',
-      potx='application/vnd.openxmlformats-officedocument.presentationml.template',
-      ppsx='application/vnd.openxmlformats-officedocument.presentationml.slideshow',
-      pptx='application/vnd.openxmlformats-officedocument.presentationml.presentation',
-      sldx='application/vnd.openxmlformats-officedocument.presentationml.slide',
-      docx='application/vnd.openxmlformats-officedocument.wordprocessingml.document',
-      dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template',
-      xlam='application/vnd.ms-excel.addin.macroEnabled.12',
-      xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12',
-      'application/octet-stream')
+    content.type <- getContentType(ext)
     response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
     return(httpResponse(200, content.type, response.content))
   })

R/shinywrappers.R

@@ -184,3 +184,50 @@ reactiveUI <- function(func) {
     return(as.character(result))
   })
 }
+
+#' File Downloads
+#' 
+#' Allows content from the Shiny application to be made available to the user as
+#' file downloads (for example, downloading the currently visible data as a CSV 
+#' file). Both filename and contents can be calculated dynamically at the time 
+#' the user initiates the download. Assign the return value to a slot on 
+#' \code{output} in your server function, and in the UI use 
+#' \code{\link{downloadButton}} or \code{\link{downloadLink}} to make the
+#' download available.
+#' 
+#' @param filename A string of the filename, including extension, that the 
+#'   user's web browser should default to when downloading the file; or a 
+#'   function that returns such a string. (Reactive values and functions may be 
+#'   used from this function.)
+#' @param content A function that takes a single argument \code{con} that is a 
+#'   file connection opened in mode \code{wb}, and writes the content of the 
+#'   download into the connection. (Reactive values and functions may be used 
+#'   from this function.)
+#' @param contentType A string of the download's 
+#'   \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for 
+#'   example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or 
+#'   \code{NA}, the content type will be guessed based on the filename 
+#'   extension, or \code{application/octet-stream} if the extension is unknown.
+#'   
+#' @examples
+#' \dontrun{
+#' # In server.R:
+#' output$downloadData <- downloadHandler(
+#'   filename = function() {
+#'     paste('data-', Sys.Date(), '.csv', sep='')
+#'   },
+#'   content = function(con) {
+#'     write.csv(data, con)
+#'   }
+#' )
+#' 
+#' # In ui.R:
+#' downloadLink('downloadData', 'Download')
+#' }
+#' 
+#' @export
+downloadHandler <- function(filename, content, contentType=NA) {
+  return(function(shinyapp, name, ...) {
+    shinyapp$registerDownload(name, filename, contentType, content)
+  })
+}