1#' Create a staticPath object
2#'
3#' The \code{staticPath} function creates a \code{staticPath} object. Note that
4#' if any of the arguments (other than \code{path}) are \code{NULL}, then that
5#' means that for this particular static path, it should inherit the behavior
6#' from the staticPathOptions set for the application as a whole.
7#'
8#' The \code{excludeStaticPath} function tells the application to ignore a
9#' particular path for static serving. This is useful when you want to include a
10#' path for static serving (like \code{"/"}) but then exclude a subdirectory of
11#' it (like \code{"/dynamic"}) so that the subdirectory will always be passed to
12#' the R code for handling requests. \code{excludeStaticPath} can be used not
13#' only for directories; it can also exclude specific files.
14#'
15#' @param path The local path.
16#' @inheritParams staticPathOptions
17#'
18#' @seealso \code{\link{staticPathOptions}}.
19#'
20#' @export
21staticPath <- function(
22  path,
23  indexhtml    = NULL,
24  fallthrough  = NULL,
25  html_charset = NULL,
26  headers      = NULL,
27  validation   = NULL
28) {
29  if (!is.character(path) || length(path) != 1 || path == "") {
30    stop("`path` must be a non-empty string.")
31  }
32
33  path <- normalizePath(path, winslash = "/", mustWork = TRUE)
34  path <- enc2utf8(path)
35
36  structure(
37    list(
38      path = path,
39      options = normalizeStaticPathOptions(staticPathOptions(
40        indexhtml    = indexhtml,
41        fallthrough  = fallthrough,
42        html_charset = html_charset,
43        headers      = headers,
44        validation   = validation,
45        exclude      = FALSE
46      ))
47    ),
48    class = "staticPath"
49  )
50}
51
52#' @rdname staticPath
53#' @export
54excludeStaticPath <- function() {
55  structure(
56    list(
57      path = "",
58      options = staticPathOptions(
59        indexhtml    = NULL,
60        fallthrough  = NULL,
61        html_charset = NULL,
62        headers      = NULL,
63        validation   = NULL,
64        exclude      = TRUE
65      )
66    ),
67    class = "staticPath"
68  )
69}
70
71as.staticPath <- function(path) {
72  UseMethod("as.staticPath", path)
73}
74
75as.staticPath.staticPath <- function(path) {
76  path
77}
78
79as.staticPath.character <- function(path) {
80  staticPath(path)
81}
82
83as.staticPath.default <- function(path) {
84  stop("Cannot convert object of class ", class(path), " to a staticPath object.")
85}
86
87#' @export
88print.staticPath <- function(x, ...) {
89  cat(format(x, ...), sep = "\n")
90  invisible(x)
91}
92
93#' @export
94format.staticPath <- function(x, ...) {
95  ret <- paste0(
96    "<staticPath>\n",
97    "  Local path:        ", x$path, "\n",
98    format_opts(x$options)
99  )
100}
101
102#' Create options for static paths
103#'
104#'
105#' @param indexhtml If an index.html file is present, should it be served up
106#'   when the client requests the static path or any subdirectory?
107#' @param fallthrough With the default value, \code{FALSE}, if a request is made
108#'   for a file that doesn't exist, then httpuv will immediately send a 404
109#'   response from the background I/O thread, without needing to call back into
110#'   the main R thread. This offers the best performance. If the value is
111#'   \code{TRUE}, then instead of sending a 404 response, httpuv will call the
112#'   application's \code{call} function, and allow it to handle the request.
113#' @param html_charset When HTML files are served, the value that will be
114#'   provided for \code{charset} in the Content-Type header. For example, with
115#'   the default value, \code{"utf-8"}, the header is \code{Content-Type:
116#'   text/html; charset=utf-8}. If \code{""} is used, then no \code{charset}
117#'   will be added in the Content-Type header.
118#' @param headers Additional headers and values that will be included in the
119#'   response.
120#' @param validation An optional validation pattern. Presently, the only type of
121#'   validation supported is an exact string match of a header. For example, if
122#'   \code{validation} is \code{'"abc" = "xyz"'}, then HTTP requests must have a
123#'   header named \code{abc} (case-insensitive) with the value \code{xyz}
124#'   (case-sensitive). If a request does not have a matching header, than httpuv
125#'   will give a 403 Forbidden response. If the \code{character(0)} (the
126#'   default), then no validation check will be performed.
127#' @param exclude Should this path be excluded from static serving? (This is
128#'   only to be used internally, for \code{\link{excludeStaticPath}}.)
129#'
130#' @export
131staticPathOptions <- function(
132  indexhtml    = TRUE,
133  fallthrough  = FALSE,
134  html_charset = "utf-8",
135  headers      = list(),
136  validation   = character(0),
137  exclude      = FALSE
138) {
139  res <- structure(
140    list(
141      indexhtml    = indexhtml,
142      fallthrough  = fallthrough,
143      html_charset = html_charset,
144      headers      = headers,
145      validation   = validation,
146      exclude      = exclude
147    ),
148    class = "staticPathOptions"
149  )
150
151  normalizeStaticPathOptions(res)
152}
153
154#' @export
155print.staticPathOptions <- function(x, ...) {
156  cat(format(x, ...), sep = "\n")
157  invisible(x)
158}
159
160
161#' @export
162format.staticPathOptions <- function(x, ...) {
163  paste0(
164    "<staticPathOptions>\n",
165    format_opts(x, format_empty = "<none>")
166  )
167}
168
169format_opts <- function(x, format_empty = "<inherit>") {
170  format_option <- function(opt) {
171    if (is.null(opt) || length(opt) == 0) {
172      format_empty
173
174    } else if (!is.null(names(opt))) {
175      # Named character vector
176      lines <- mapply(
177        function(name, value) paste0('    "', name, '" = "', value, '"'),
178        names(opt),
179        opt,
180        SIMPLIFY = FALSE,
181        USE.NAMES = FALSE
182      )
183
184      lines <- paste(as.character(lines), collapse = "\n")
185      lines <- paste0("\n", lines)
186      lines
187
188    } else {
189      paste(as.character(opt), collapse = " ")
190    }
191  }
192  ret <- paste0(
193    "  Use index.html:    ", format_option(x$indexhtml),    "\n",
194    "  Fallthrough to R:  ", format_option(x$fallthrough),  "\n",
195    "  HTML charset:      ", format_option(x$html_charset), "\n",
196    "  Extra headers:     ", format_option(x$headers),      "\n",
197    "  Validation params: ", format_option(x$validation),   "\n",
198    "  Exclude path:      ", format_option(x$exclude),      "\n"
199  )
200}
201
202
203# This function always returns a named list of staticPath objects. The names
204# will all start with "/". The input can be a named character vector or a
205# named list containing a mix of strings and staticPath objects. This function
206# is idempotent.
207normalizeStaticPaths <- function(paths) {
208  if (is.null(paths) || length(paths) == 0) {
209    return(list())
210  }
211
212  if (any_unnamed(paths)) {
213    stop("paths must be a named character vector, a named list containing strings and staticPath objects, or NULL.")
214  }
215
216  if (!is.character(paths) && !is.list(paths)) {
217    stop("paths must be a named character vector, a named list containing strings and staticPath objects, or NULL.")
218  }
219
220  # Convert to list of staticPath objects. Need this verbose wrapping of
221  # as.staticPath because of S3 dispatch for non-registered methods.
222  paths <- lapply(paths, function(path) as.staticPath(path))
223
224  # Make sure URL paths have a leading '/' and no trailing '/'.
225  names(paths) <- vapply(names(paths), function(path) {
226    path <- enc2utf8(path)
227
228    if (path == "") {
229      stop("All paths must be non-empty strings.")
230    }
231    # Ensure there's a leading / for every path
232    if (substr(path, 1, 1) != "/") {
233      path <- paste0("/", path)
234    }
235    # Strip trailing slashes, except when the path is just "/".
236    if (path != "/") {
237      path <- sub("/+$", "", path)
238    }
239
240    path
241  }, "")
242
243  paths
244}
245
246# Takes a staticPathOptions object and modifies it so that the resulting
247# object is easier to work with on the C++ side. The resulting object is not
248# meant to be modified on the R side. This function is idempotent; if the
249# object has already been normalized, it will not be modified. For each entry,
250# a NULL means to inherit.
251normalizeStaticPathOptions <- function(opts) {
252  if (isTRUE(attr(opts, "normalized", exact = TRUE))) {
253    return(opts)
254  }
255
256  # html_charset can accept "" or character(0). But on the C++ side, we want
257  # "".
258  if (!is.null(opts$html_charset)) {
259    if (length(opts$html_charset) == 0) {
260      opts$html_charset <- ""
261    }
262  }
263
264  if (!is.null(opts$exclude)) {
265    if (!is.logical(opts$exclude) || length(opts$exclude) != 1) {
266      stop("`exclude` option must be TRUE or FALSE.")
267    }
268  }
269
270  # Can be a named list of strings, or a named character vector. On the C++
271  # side, we want a named character vector.
272  if (is.list(opts$headers)) {
273    # Convert list to named character vector
274    opts$headers <- unlist(opts$headers, recursive = FALSE)
275    # Special case: if opts$headers was an empty list before unlist(), it is
276    # now NULL. Replace it with an empty named character vector.
277    if (length(opts$headers) == 0) {
278      opts$headers <- c(a="a")[0]
279    }
280
281    if (!is.character(opts$headers) || any_unnamed(opts$headers)) {
282      stop("`headers` option must be a named list or character vector.")
283    }
284  }
285
286  if (!is.null(opts$validation)) {
287    if (!is.character(opts$validation) || length(opts$validation) > 1) {
288      stop("`validation` option must be a character vector with zero or one element.")
289    }
290
291    # Both "" and character(0) result in character(0). Length-1 strings other
292    # than "" will be parsed.
293    if (length(opts$validation) == 1) {
294      if (opts$validation == "") {
295        opts$validation <- character(0)
296
297      } else {
298        fail <- FALSE
299        tryCatch(
300          p <- parse(text = opts$validation)[[1]],
301          error = function(e) fail <<- TRUE
302        )
303        if (!fail) {
304          if (length(p) != 3            ||
305              p[[1]] != as.symbol("==") ||
306              !is.character(p[[2]])     ||
307              length(p[[2]]) != 1       ||
308              !is.character(p[[3]])     ||
309              length(p[[3]]) != 1)
310          {
311            fail <- TRUE
312          }
313        }
314        if (fail) {
315          stop("`validation` must be a string of the form: '\"xxx\" == \"yyy\"'")
316        }
317
318        # Turn it into a char vector for easier processing in C++
319        opts$validation <- as.character(p)
320      }
321    }
322  }
323
324  attr(opts, "normalized") <- TRUE
325  opts
326}
327