R/middleware-plus-supporting.R

In epiviz/epivizr-release: R Interface to epiviz web app

# Copyright (c) 2012-2014, RStudio, Inc.


# Artistic License 2.0
# 
# Copyright (c) 2000-2006, The Perl Foundation.
# 
# Everyone is permitted to copy and distribute verbatim copies of this
# license document, but changing it is not allowed.
# 
# Preamble
# ********
#   
#   This license establishes the terms under which a given free software
# Package may be copied, modified, distributed, and/or redistributed.  The
# intent is that the Copyright Holder maintains some artistic control over
# the development of that Package while still keeping the Package
# available as open source and free software.
# 
# You are always permitted to make arrangements wholly outside of this
# license directly with the Copyright Holder of a given Package.  If the
# terms of this license do not permit the full use that you propose to
# make of the Package, you should contact the Copyright Holder and seek a
# different licensing arrangement.
# 
# Definitions
# ***********
#   
#   "Copyright Holder" means the individual(s) or organization(s) named in
# the copyright notice for the entire Package.
# 
# "Contributor" means any party that has contributed code or other
# material to the Package, in accordance with the Copyright Holder's
# procedures.
# 
# "You" and "your" means any person who would like to copy, distribute, or
# modify the Package.
# 
# "Package" means the collection of files distributed by the Copyright
# Holder, and derivatives of that collection and/or of those files.  A
# given Package may consist of either the Standard Version, or a Modified
# Version.
# 
# "Distribute" means providing a copy of the Package or making it
# accessible to anyone else, or in the case of a company or organization,
# to others outside of your company or organization.
# 
# "Distributor Fee" means any fee that you charge for Distributing this
# Package or providing support for this Package to another party.  It does
# not mean licensing fees.
# 
# "Standard Version" refers to the Package if it has not been modified, or
# has been modified only in ways explicitly requested by the Copyright
# Holder.
# 
# "Modified Version" means the Package, if it has been changed, and such
# changes were not explicitly requested by the Copyright Holder.
# 
# "Original License" means this Artistic License as Distributed with the
# Standard Version of the Package, in its current version or as it may be
# modified by The Perl Foundation in the future.
# 
# "Source" form means the source code, documentation source, and
# configuration files for the Package.
# 
# "Compiled" form means the compiled bytecode, object code, binary, or any
# other form resulting from mechanical transformation or translation of
# the Source form.
# 
# Permission for Use and Modification Without Distribution
# ********************************************************
# 
# (1) You are permitted to use the Standard Version and create and use
# Modified Versions for any purpose without restriction, provided that you
# do not Distribute the Modified Version.
# 
# Permissions for Redistribution of the Standard Version
# ******************************************************
# 
# (2) You may Distribute verbatim copies of the Source form of the
# Standard Version of this Package in any medium without restriction,
# either gratis or for a Distributor Fee, provided that you duplicate all
# of the original copyright notices and associated disclaimers.  At your
# discretion, such verbatim copies may or may not include a Compiled form
# of the Package.
# 
# (3) You may apply any bug fixes, portability changes, and other
# modifications made available from the Copyright Holder.  The resulting
# Package will still be considered the Standard Version, and as such will
# be subject to the Original License.
# 
# Distribution of Modified Versions of the Package as Source
# **********************************************************
# 
# (4) You may Distribute your Modified Version as Source (either gratis or
# for a Distributor Fee, and with or without a Compiled form of the
# Modified Version) provided that you clearly document how it differs from
# the Standard Version, including, but not limited to, documenting any
# non-standard features, executables, or modules, and provided that you do
# at least ONE of the following:
# 
# (a) make the Modified Version available to the Copyright Holder of the
# Standard Version, under the Original License, so that the Copyright
# Holder may include your modifications in the Standard Version.
# 
# (b) ensure that installation of your Modified Version does not prevent
# the user installing or running the Standard Version.  In addition, the
# Modified Version must bear a name that is different from the name of the
# Standard Version.
# 
# (c) allow anyone who receives a copy of the Modified Version to make the
# Source form of the Modified Version available to others under
# 
# (i) the Original License or
# 
# (ii) a license that permits the licensee to freely copy, modify and
# redistribute the Modified Version using the same licensing terms that
# apply to the copy that the licensee received, and requires that the
# Source form of the Modified Version, and of any works derived from it,
# be made freely available in that license fees are prohibited but
# Distributor Fees are allowed.
# 
# Distribution of Compiled Forms of the Standard Version or Modified
# ******************************************************************
# Versions without the Source
# ***************************
# 
# (5) You may Distribute Compiled forms of the Standard Version without
# the Source, provided that you include complete instructions on how to
# get the Source of the Standard Version.  Such instructions must be valid
# at the time of your distribution.  If these instructions, at any time
# while you are carrying out such distribution, become invalid, you must
# provide new instructions on demand or cease further distribution.  If
# you provide valid instructions or cease distribution within thirty days
# after you become aware that the instructions are invalid, then you do
# not forfeit any of your rights under this license.
# 
# (6) You may Distribute a Modified Version in Compiled form without the
# Source, provided that you comply with Section 4 with respect to the
# Source of the Modified Version.
# 
# Aggregating or Linking the Package
# **********************************
# 
# (7) You may aggregate the Package (either the Standard Version or
# Modified Version) with other packages and Distribute the resulting
# aggregation provided that you do not charge a licensing fee for the
# Package.  Distributor Fees are permitted, and licensing fees for other
# components in the aggregation are permitted.  The terms of this license
# apply to the use and Distribution of the Standard or Modified Versions
# as included in the aggregation.
# 
# (8) You are permitted to link Modified and Standard Versions with other
# works, to embed the Package in a larger work of your own, or to build
# stand-alone binary or bytecode versions of applications that include the
# Package, and Distribute the result without restriction, provided the
# result does not expose a direct interface to the Package.
# 
# Items That are Not Considered Part of a Modified Version
# ********************************************************
# 
# (9) Works (including, but not limited to, modules and scripts) that
# merely extend or make use of the Package, do not, by themselves, cause
# the Package to be a Modified Version.  In addition, such works are not
# considered parts of the Package itself, and are not subject to the terms
# of this license.
# 
# General Provisions
# ******************
# 
# (10) Any use, modification, and distribution of the Standard or Modified
# Versions is governed by this Artistic License.  By using, modifying or
# distributing the Package, you accept this license.  Do not use, modify,
# or distribute the Package, if you do not accept this license.
# 
# (11) If your Modified Version has been derived from a Modified Version
# made by someone other than you, you are nevertheless required to ensure
# that your Modified Version complies with the requirements of this
# license.
# 
# (12) This license does not grant you the right to use any trademark,
# service mark, tradename, or logo of the Copyright Holder.
# 
# (13) This license includes the non-exclusive, worldwide, free-of-charge
# patent license to make, have made, use, offer to sell, sell, import and
# otherwise transfer the Package with respect to any patent claims
# licensable by the Copyright Holder that are necessarily infringed by the
# Package.  If you institute patent litigation (including a cross-claim or
# counterclaim) against any party alleging that the Package constitutes
# direct or contributory patent infringement, then this Artistic License
# to you shall terminate on the date that such litigation is filed.
# 
# (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT
# HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES.  THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
# PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT
# PERMITTED BY YOUR LOCAL LAW.  UNLESS REQUIRED BY LAW, NO COPYRIGHT
# HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
# OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.




# 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.
#
# Example:
# resolve("/Users/jcheng", "shiny")  # "/Users/jcheng/shiny"
# resolve("/Users/jcheng", "./shiny")  # "/Users/jcheng/shiny"
# resolve("/Users/jcheng", "shiny/../shiny/")  # "/Users/jcheng/shiny"
# resolve("/Users/jcheng", ".")  # NULL
# resolve("/Users/jcheng", "..")  # NULL
# resolve("/Users/jcheng", "shiny/..")  # NULL
resolve <- function(dir, relpath) {
  abs.path <- file.path(dir, relpath)
  if (!file.exists(abs.path))
    return(NULL)
  abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE)
  dir <- normalizePath(dir, winslash='/', mustWork=TRUE)
  # trim the possible trailing slash under Windows (#306)
  if (isWindows()) dir <- sub('/$', '', dir)
  if (nchar(abs.path) <= nchar(dir) + 1)
    return(NULL)
  if (substr(abs.path, 1, nchar(dir)) != dir ||
      substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') {
    return(NULL)
  }
  return(abs.path)
}

isWindows <- function() .Platform$OS.type == 'windows'

`%OR%` <- function(x, y) {
  if (is.null(x) || isTRUE(is.na(x)))
    y
  else
    x
}




# This file contains a general toolkit for routing and combining bits of
# HTTP-handling logic. It is similar in spirit to Rook (and Rack, and WSGI, and
# Connect, and...) but adds cascading and routing.
#
# This file is called "middleware" because that's the term used for these bits
# of logic in these other frameworks. However, our code uses the word "handler"
# so we'll stick to that for the rest of this document; just know that they're
# basically the same concept.
#
# ## Intro to handlers
#
# A **handler** (or sometimes, **httpHandler**) is a function that takes a
# `req` parameter--a request object as described in the Rook specification--and
# returns `NULL`, or an `httpResponse`.
#
## ------------------------------------------------------------------------
httpResponse <- function(status = 200,
                         content_type = "text/html; charset=UTF-8",
                         content = "",
                         headers = list()) {
  # Make sure it's a list, not a vector
  headers <- as.list(headers)
  if (is.null(headers$`X-UA-Compatible`))
    headers$`X-UA-Compatible` <- "chrome=1"
  resp <- list(status = status, content_type = content_type, content = content,
               headers = headers)
  class(resp) <- 'httpResponse'
  return(resp)
}

#
# You can think of a web application as being simply an aggregation of these
# functions, each of which performs one kind of duty. Each handler in turn gets
# a look at the request and can decide whether it knows how to handle it. If
# so, it returns an `httpResponse` and processing terminates; if not, it
# returns `NULL` and the next handler gets to execute. If the final handler
# returns `NULL`, a 404 response should be returned.
#
# We have a similar construct for websockets: **websocket handlers** or
# **wsHandlers**. These take a single `ws` argument which is the websocket
# connection that was just opened, and they can either return `TRUE` if they
# are handling the connection, and `NULL` to pass responsibility on to the next
# wsHandler.
#
# ### Combining handlers
#
# Since it's so common for httpHandlers to be invoked in this "cascading"
# fashion, we'll introduce a function that takes zero or more handlers and
# returns a single handler. And while we're at it, making a directory of static
# content available is such a common thing to do, we'll allow strings
# representing paths to be used instead of handlers; any such strings we
# encounter will be converted into `staticHandler` objects.
#
## ------------------------------------------------------------------------
joinHandlers <- function(handlers) {
  # Zero handlers; return a null handler
  if (length(handlers) == 0)
    return(function(req) NULL)

  # Just one handler (function)? Return it.
  if (is.function(handlers))
    return(handlers)

  handlers <- lapply(handlers, function(h) {
    if (is.character(h))
      return(staticHandler(h))
    else
      return(h)
  })

  # Filter out NULL
  handlers <- handlers[!sapply(handlers, is.null)]

  if (length(handlers) == 0)
    return(function(req) NULL)
  if (length(handlers) == 1)
    return(handlers[[1]])

  function(req) {
    for (handler in handlers) {
      response <- handler(req)
      if (!is.null(response))
        return(response)
    }
    return(NULL)
  }
}

#
# Note that we don't have an equivalent of `joinHandlers` for wsHandlers. It's
# easy to imagine it, we just haven't needed one.
#
# ### Handler routing
#
# Handlers do not have a built-in notion of routing. Conceptually, given a list
# of handlers, all the handlers are peers and they all get to see every request
# (well, up until the point that a handler returns a response).
#
# You could implement routing in each handler by checking the request's
# `PATH_INFO` field, but since it's such a common need, let's make it simple by
# introducing a `routeHandler` function. This is a handler
# [decorator](http://en.wikipedia.org/wiki/Decorator_pattern) and it's
# responsible for 1) filtering out requests that don't match the given route,
# and 2) temporarily modifying the request object to take the matched part of
# the route off of the `PATH_INFO` (and add it to the end of `SCRIPT_NAME`).
# This way, the handler doesn't need to figure out about what part of its URL
# path has already been matched via routing.
#
# (BTW, it's safe for `routeHandler` calls to nest.)
#
## ------------------------------------------------------------------------
routeHandler <- function(prefix, handler) {
  force(prefix)
  force(handler)

  if (identical("", prefix))
    return(handler)

  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
    stop("Invalid URL prefix \"", prefix, "\"")
  }

  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
  function(req) {
    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
      origScript <- req$SCRIPT_NAME
      origPath <- req$PATH_INFO
      on.exit({
        req$SCRIPT_NAME <- origScript
        req$PATH_INFO <- origPath
      }, add = TRUE)
      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
      req$PATH_INFO <- pathInfo
      return(handler(req))
    } else {
      return(NULL)
    }
  }
}

#
# We have a version for websocket handlers as well. Pity about the copy/paste
# job.
#
## ------------------------------------------------------------------------
routeWSHandler <- function(prefix, wshandler) {
  force(prefix)
  force(wshandler)

  if (identical("", prefix))
    return(wshandler)

  if (length(prefix) != 1 || !isTRUE(grepl("^/[^\\]+$", prefix))) {
    stop("Invalid URL prefix \"", prefix, "\"")
  }

  pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
  function(ws) {
    req <- ws$request
    if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
      origScript <- req$SCRIPT_NAME
      origPath <- req$PATH_INFO
      on.exit({
        req$SCRIPT_NAME <- origScript
        req$PATH_INFO <- origPath
      }, add = TRUE)
      pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
      req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
      req$PATH_INFO <- pathInfo
      return(wshandler(ws))
    } else {
      return(NULL)
    }
  }
}

#
# ### Handler implementations
#
# Now let's actually write some handlers. Note that these functions aren't
# *themselves* handlers, you call them and they *return* a handler. Handler
# factory functions, if you will.
#
# Here's one that serves up static assets from a directory.
#
## ------------------------------------------------------------------------
staticHandler <- function(root) {
  force(root)
  return(function(req) {
    if (!identical(req$REQUEST_METHOD, 'GET'))
      return(NULL)

    path <- req$PATH_INFO

    if (is.null(path))
      return(httpResponse(400, content="<h1>Bad Request</h1>"))

    if (path == '/')
      path <- '/index.html'

    abs.path <- resolve(root, path)
    if (is.null(abs.path))
      return(NULL)

    content.type <- mime::guess_type(abs.path)
    response.content <- readBin(abs.path, 'raw', n=file.info(abs.path)$size)
    return(httpResponse(200, content.type, response.content))
  })
}

#
# ## Handler manager
#
# The handler manager gives you a place to register handlers (of both http and
# websocket varieties) and provides an httpuv-compatible set of callbacks for
# invoking them.
#
# Create one of these, make zero or more calls to `addHandler` and
# `addWSHandler` methods (order matters--first one wins!), and then pass the
# return value of `createHttpuvApp` to httpuv's `startServer` function.
#
## ------------------------------------------------------------------------
HandlerList <- R6Class("HandlerList",
  portable = FALSE,
  class = FALSE,
  public = list(
    handlers = list(),

    add = function(handler, key, tail = FALSE) {
      if (!is.null(handlers[[key]]))
        stop("Key ", key, " already in use")
      newList <- structure(names=key, list(handler))

      if (length(handlers) == 0)
        handlers <<- newList
      else if (tail)
        handlers <<- c(handlers, newList)
      else
        handlers <<- c(newList, handlers)
    },
    remove = function(key) {
      handlers[key] <<- NULL
    },
    clear = function() {
      handlers <<- list()
    },
    invoke = function(...) {
      for (handler in handlers) {
        result <- handler(...)
        if (!is.null(result))
          return(result)
      }
      return(NULL)
    }
  )
)

HandlerManager <- R6Class("HandlerManager",
  portable = FALSE,
  class = FALSE,
  public = list(
    handlers = "HandlerList",
    wsHandlers = "HandlerList",

    initialize = function() {
      handlers <<- HandlerList$new()
      wsHandlers <<- HandlerList$new()
    },

    addHandler = function(handler, key, tail = FALSE) {
      handlers$add(handler, key, tail)
    },
    removeHandler = function(key) {
      handlers$remove(key)
    },
    addWSHandler = function(wsHandler, key, tail = FALSE) {
      wsHandlers$add(wsHandler, key, tail)
    },
    removeWSHandler = function(key) {
      wsHandlers$remove(key)
    },
    clear = function() {
      handlers$clear()
      wsHandlers$clear()
    },
    createHttpuvApp = function() {
      list(
        onHeaders = function(req) {
          maxSize <- getOption('shiny.maxRequestSize') %OR% (5 * 1024 * 1024)
          if (maxSize <= 0)
            return(NULL)

          reqSize <- 0
          if (length(req$CONTENT_LENGTH) > 0)
            reqSize <- as.numeric(req$CONTENT_LENGTH)
          else if (length(req$HTTP_TRANSFER_ENCODING) > 0)
            reqSize <- Inf

          if (reqSize > maxSize) {
            return(list(status = 413L,
              headers = list(
                'Content-Type' = 'text/plain'
              ),
              body = 'Maximum upload size exceeded'))
          }
          else {
            return(NULL)
          }
        },
        call = .httpServer(
          function (req) {
            return(handlers$invoke(req))
          },
          getOption('shiny.sharedSecret')
        ),
        onWSOpen = function(ws) {
          return(wsHandlers$invoke(ws))
        }
      )
    },
    .httpServer = function(handler, sharedSecret) {
      filter <- getOption('shiny.http.response.filter')
      if (is.null(filter))
        filter <- function(req, response) response

      function(req) {
        if (!is.null(sharedSecret)
          && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
          return(list(status=403,
            body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
            headers=list('Content-Type' = 'text/html')))
        }

        response <- handler(req)
        if (is.null(response))
          response <- httpResponse(404, content="<h1>Not Found</h1>")

        if (inherits(response, "httpResponse")) {
          headers <- as.list(response$headers)
          headers$'Content-Type' <- response$content_type

          response <- filter(req, response)
          return(list(status=response$status,
            body=response$content,
            headers=headers))
        } else {
          # Assume it's a Rook-compatible response
          return(response)
        }
      }
    }
  )
)

#
# ## Next steps
#
# See server.R and middleware-shiny.R to see actual implementation and usage of
# handlers in the context of Shiny.