-
Notifications
You must be signed in to change notification settings - Fork 8
/
run.R
106 lines (92 loc) · 4.16 KB
/
run.R
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
.run <- function(request, root, path) {
as.character(try({
.GlobalEnv$webapi <- 1.1
.e$.out <- ''
cmd <- 'html'
ct <- 'text/html'
setwd(file.path(root, "tmp"))
# deprecated compatibility settings - should go away...
requestURI <- request$uri
remote.addr <- request$client.ip
raw.cookies <- request$raw.cookies
qs <- request$query.string
# parse parameters in the order of precedence: query string, multipart, urlencoded
pars <- list()
if (grepl('^application/x-www-form-urlencoded', request$c.type) && is.raw(request$body)) {
ue <- rawToChar(request$body)
for (x in strsplit(strsplit(ue,'&')[[1]], '=')) pars[[URLdecode(x[1])]] <- URLdecode(x[2])
}
if (grepl("^multipart", request$c.type)) pars <- parse.multipart()
# add qs
if (is.null(request$query.vector)) {
for (x in strsplit(strsplit(qs,'&')[[1]], '=')) if (length(x) > 1L) pars[[URLdecode(x[1])]] <- URLdecode(x[2])
} else {
qs <- request$query.vector
qn <- names(qs)
for (i in seq.int(qs)) pars[[qn[i]]] <- qs[i]
}
# find the script
request$path.info <- ''
sfn <- sprintf("%s/web.R/%s.R", root, path)
if (!file.exists(sfn)) { # if the file doesn't exist, we try to separate script name from PATH_INFO
left <- path
while (nzchar(left <- gsub("/[^/]*$", "", left)) && !file.exists(cand <- sprintf("%s/web.R/%s.R", root, left))) { if (!grepl("/", left)) left <- '' }
if (!nzchar(left))
return(c("html", paste("Script ", path, ".R not found", sep=''), "text/html", "Status: 404 Script not found"))
request$path.info <- gsub(left, "", path, fixed=TRUE)
sfn <- cand
}
oclear(TRUE, TRUE)
.GlobalEnv$request <- request
if(exists('init') && is.function(init)) init()
source(sfn, local=TRUE)
as.WebResult(do.call(run, pars))
}, silent=TRUE))
}
## URLencode is *not* vectorized in R, believe it or not so we have to work around that ...
URLenc <- function(x) unlist(lapply(x, URLencode))
### this maps the Rhttpd/Rserve direct HTTP API into .run
.http.request <- function(url, query, body, headers) {
root <- getOption("FastRWeb.root")
if (is.null(root)) root <- "/var/FastRWeb"
request <- list(uri=url, method='GET', c.type='', c.length=-1, body=NULL, client.ip='0.0.0.0', query.string='', raw.cookies='')
if (length(query)) request$query.vector <- query ## back-door for parsed queries
## process headers to pull out request method (if supplied) and cookies
if (is.raw(headers)) headers <- rawToChar(headers)
if (is.character(headers)) {
## parse the headers into key/value pairs, collapsing multi-line values
h.lines <- unlist(strsplit(gsub("[\r\n]+[ \t]+"," ", headers), "[\r\n]+"))
h.keys <- tolower(gsub(":.*", "", h.lines))
h.vals <- gsub("^[^:]*:[[:space:]]*", "", h.lines)
names(h.vals) <- h.keys
h.vals <- h.vals[grep("^[^:]+:", h.lines)]
h.keys <- names(h.vals)
if ("request-method" %in% h.keys) request$method <- c(h.vals["request-method"])
if ("client-addr" %in% h.keys) request$client.ip <- c(h.vals["client-addr"])
if ("cookie" %in% names(h.vals)) request$raw.cookies <- paste(h.vals[h.keys == "cookie"], collapse=" ")
}
## this is a bit convoluted - the HTTP already parses the body - disable it where you can
if (!is.raw(body)) {
if (length(body)) {
sb <- paste(unlist(lapply(names(body), function(x) paste(URLencode(x),"=",URLencode(as.character(body[[x]])),sep=''))),collapse='&')
request$body <- charToRaw(sb)
request$c.length <- length(request$body)
request$c.type <- 'application/x-www-form-urlencoded'
}
} else {
request$body <- body
request$c.type <- attr(body, "content-type")
request$c.length <- length(body)
}
r <- .run(request, root, url)
if (length(r) < 2) return(list(r))
cmd <- r[1]
payload <- r[2]
ct <- if (length(r) > 2) r[3] else "text/html"
h <- if (length(r) > 3) r[4] else character(0)
if (any(nchar(h) == 0L)) h <- h[nchar(h) > 0]
if (cmd == "tmpfile" || cmd == "file") {
fn <- paste(root, if (cmd == "tmpfile") "tmp" else "web", gsub("/", "_", payload, fixed=TRUE), sep='/')
list(file=fn, ct, h)
} else list(payload, ct, h)
}