Repository navigation
Expand file tree
/
Copy pathserver.r
More file actions
121 lines (104 loc) · 3.61 KB
/
Copy pathserver.r
File metadata and controls
121 lines (104 loc) · 3.61 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#' Start server for r2d3 files.
#'
#' This isn't absolutely necessary, but if you run the html from a
#' \code{file://} you can't request other local files. This server also
#' provides some convenience features like:
#'
#' \itemize{
#' \item If the file doesn't exist in the base directory, we'll look in
#' the installed package directory. That way you don't need to worry
#' about having \code{d3.js} etc installed.
#'
#' \item If a html file doesn't exist, a template will be rendered that
#' runs the r2d3 js using a json file of the matching name.
#' }
#' @param base A directory specifying the base path where files are looked
#' for.
#' @param appname The name of the application - this is only needed if you
#' want to server multiple r2d3 servers out of different directories.
#' @param browse if \code{TRUE} will open the server in the browser
#' @return (invisibly) the Rook server.
#' @export
#' @import Rook
#' @examples
#' start_server(system.file("examples", package = "r2d3"))
start_server <- function(base, appname = "r2d3", browse = interactive()) {
stopifnot(file.exists(base), file.info(base)$isdir)
base <- normalizePath(base)
server <- Rhttpd$new()
server$add(make_router(base), appname)
server$start(quiet = TRUE)
if (browse) server$browse(appname)
invisible(server)
}
make_router <- function(base) {
function(env) {
req <- Request$new(env)
path <- req$path_info()
# Found in base directory, so serve it from there
base_path <- file.path(base, path)
if (file.exists(base_path)) {
if (file.info(base_path)$isdir) {
if (grepl("/$", path)) {
# It's a directory, so make a basic index
return(serve_index(base_path))
} else {
return(redirect(paste0(req$path(), "/")))
}
} else {
return(serve_file(base_path))
}
}
# Found in installed path, so serve it from there
installed_path <- file.path(inst_path(), path)
if (file.exists(installed_path)) return(serve_file(installed_path))
# If it's an html file, and a json file with the same name exists,
# serve the standard template
json_path <- change_ext(path, "json")
if (file.exists(file.path(base, json_path))) {
return(serve_scaffold(paste0(req$script_name(), json_path)))
}
# Couldn't find it, so return 404.
res <- Response$new(status = 404L)
res$header("Content-type", "text/plain")
res$write(paste("Couldn't find path:", path))
res$finish()
}
}
#' @importFrom tools file_ext
serve_file <- function(path) {
stopifnot(file.exists(path))
fi <- file.info(path)
body <- readBin(path, 'raw', fi$size)
res <- Response$new()
res$header("Content-Type", Mime$mime_type(paste0(".", file_ext(path))))
res$write(rawToChar(body))
res$finish()
}
#' @importFrom whisker whisker.render
serve_template <- function(template_path, data) {
template <- readLines(file.path(inst_path(), template_path))
body <- whisker.render(template, data)
res <- Response$new()
res$header("Content-Type", "text/html")
res$write(body)
res$finish()
}
serve_scaffold <- function(path) {
serve_template("template.html", list(json_path = path))
}
serve_index <- function(path) {
files <- basename(dir(path))
json <- files[file_ext(files) == "json"]
files <- sort(c(files, change_ext(json, "html")))
serve_template("index.html", list(files = files))
}
redirect <- function(path) {
res <- Response$new(status = 301L)
res$header("Location", path)
res$finish()
}
#' @importFrom tools file_path_sans_ext
change_ext <- function(x, new_ext) {
paste0(file_path_sans_ext(x), ".", new_ext)
}