RhttpdApp <- setRefClass(
'RhttpdApp',
fields = c('app','name','path','appEnv'),
methods = list(
initialize = function(app=NULL,name=NULL,...){
if (is.null(name) || !is.character(name))
base::stop("Need a proper app 'name'")
.self$name <- name
if (is.character(app) && file.exists(app)){
oldwd <- setwd(dirname(app))
on.exit(setwd(oldwd))
appEnv <<- new.env(parent=globalenv())
appEnv$.appFile <<- normalizePath(basename(app))
appEnv$.mtime <<- as.integer(file.info(appEnv$.appFile)$mtime)
sys.source(appEnv$.appFile,envir=.self$appEnv)
if (exists(.self$name,.self$appEnv,inherits=FALSE))
.self$app <- get(.self$name,.self$appEnv)
else if (exists('app',.self$appEnv,inherits=FALSE))
.self$app <- get('app',.self$appEnv)
else
base::stop("Cannot find a suitable app in file ",app)
} else {
.self$app <- app
.self$name <- name
.self$appEnv <- NULL
}
if (!is_rookable(.self$app))
base::stop("App is not rookable'")
.self$path <- ifelse(.self$name=='httpd','', paste('/custom',.self$name,sep='/'))
callSuper(...)
}
)
)
RhttpdInputStream <- setRefClass(
'RhttpdInputStream',
fields = c('postBody','pos'),
methods = list(
initialize = function(postBody=NULL,...){
if (is.null(postBody)) {
postBody <<- raw(0) # empty post body
} else if (is.character(postBody)){
postBody <<- charToRaw(paste(names(postBody),postBody,sep='=',collapse='&'))
} else {
postBody <<- postBody
}
pos <<- 1
callSuper(...)
},
read_lines = function(n = -1L){
if (n==0 || pos > length(postBody)) return(character())
nls <- which(charToRaw('\n')==postBody[pos:length(postBody)])
rv <- character(ifelse(n>-1L,n,0))
lc <- 1
for (i in nls){
rv[lc] <- rawToChar(postBody[pos:(pos+i-1)])
pos <<- pos + pos + i
lc <- lc + 1
if (pos > length(postBody) || lc > n)
break
}
if (lc <= n && pos <= length(postBody))
rv[lc] <- rawToChar(postBody[pos:length(postBody)])
rv
},
read = function(l = -1L){
if (l == 0 || pos >= length(postBody)) return(raw())
if (l < 0){
rv <- postBody[pos:length(postBody)]
pos <<- length(postBody)
return(rv)
} else {
rv <- postBody[pos:(pos+(l-1))]
pos <<- pos + l
return(rv)
}
},
rewind = function(){
pos <<- 1
}
)
)
RhttpdErrorStream <- setRefClass(
'RhttpdErrorStream',
methods = list(
flush = function() { base::flush(stderr()) },
cat = function(...,sep=" ",fill=FALSE,labels=NULL)
{ base::cat(...,sep=sep,fill=fill,labels=labels,file=stderr()) }
)
)
Rhttpd <- setRefClass(
'Rhttpd',
fields = c('appList','listenAddr','httpdOrig','listenPort'),
methods = list(
initialize = function(...){
appList <<- list()
listenAddr <<- '127.0.0.1'
listenPort <<- 0L
callSuper(...)
},
finalize = function(){
if (length(appList) == 0) return()
for (i in rev(1:length(appList))){
remove(appList[[i]])
}
},
full_url = function(i){
paste('http://',listenAddr,':',listenPort,appList[[i]]$path,sep='')
},
launch = function(...){
.self$start(quiet=TRUE)
# Try to create a new app from the supplied arguments
app <- RhttpdApp$new(...)
if (add(app)){
appName <- app$name
browseURL(full_url(which(appName == names(appList))))
invisible()
} else {
base::stop("No app to launch")
}
},
open = function(x){
if (missing(x)) return(print())
if (is.numeric(x) || is.integer(x)){
x <- as.integer(x)
if (!is.null(appList[[x]]))
return(invisible(browseURL(full_url(x))))
else
base::stop("No app at index ",x)
} else if (is.character(x)){
for (i in 1:length(appList)){
if (appList[[i]]$name==x){
return(invisible(browseURL(full_url(x))))
}
}
base::stop("No app named",x)
}
base::stop("Argument must be an integer or character")
},
browse = function(x) open(x),
start = function(listen='127.0.0.1',port=getOption('help.ports'),quiet=FALSE){
if(nzchar(Sys.getenv("R_DISABLE_HTTPD"))) {
warning("httpd server disabled by R_DISABLE_HTTPD", immediate. = TRUE)
utils::flush.console()
return(invisible())
}
if(grepl('rstudio',base::.Platform$GUI,ignore.case=TRUE)){
# RStudio has already set up host and port
listenPort <<- tools:::httpdPort
if (!missing(port))
warning("RStudio has already started the web server on port ",tools:::httpdPort)
return(invisible())
}
if (!missing(listen) && listen != '127.0.0.1'){
listen <- '127.0.0.1'
warning("This version of Rook can only listen on the loopback device.");
}
if (!missing(port)){
oldPorts <- getOption('help.ports')
on.exit(options(help.ports=oldPorts))
options(help.ports=port)
}
if (length(appList) == 0)
add(RhttpdApp$new(system.file('exampleApps/RookTestApp.R',package='Rook'),name='RookTest'))
listenPort <<- startDynamicHelp(TRUE)
if (listenPort == 0){
base::stop("The internal web server could not be started!")
}
if (!quiet){
cat('\nServer started on host',listen,'and port',listenPort,'. App urls are:\n\n')
invisible(lapply(names(appList),function(i){
cat('\thttp://',listen,':',listenPort,appList[[i]]$path,'\n',sep='')
}))
}
invisible()
},
stop = function(){
listenPort <<- startDynamicHelp(FALSE)
},
add = function(app=NULL,name=NULL){
if (!inherits(app,'RhttpdApp'))
app <- RhttpdApp$new(name=name,app=app)
if (!inherits(app,'RhttpdApp'))
base::stop("Need an RhttpdApp object")
appList[[app$name]] <<- app
if(app$name=='httpd'){
base::stop("Rook no longer supports assignment to tools:::httpd")
#.self$httpdOrig <- tools:::httpd
#assignInNamespace(
# app$name,
# function(path,query,postBody,headers)
# .self$handler(app$name,path,query,postBody,headers),
# 'tools'
#)
} else {
assign(
app$name,
function(path,query,postBody,headers)
.self$handler(app$name,path,query,postBody,headers),
tools:::.httpd.handlers.env
)
}
invisible(TRUE)
},
remove = function(app=NULL,all=FALSE){
if (all==TRUE){
lapply(names(appList),remove)
return(invisible(TRUE))
}
if (inherits(app,'RhttpdApp'))
name <- app$name
else if (is.character(app))
name <- app
else if (is.numeric(app) || is.integer(app))
name <- appList[[app]]$name
else
base::stop("Can only remove by object, app name, or index.")
if (is.null(appList[[name]])) return(FALSE)
appList[[name]] <<- NULL
ret <- FALSE
if(name=='httpd' && !is.null(httpdOrig)){
tools:::httpd <- httpdOrig
ret <- TRUE
} else if (exists(name,tools:::.httpd.handlers.env)){
rm(list=name,pos=tools:::.httpd.handlers.env)
ret <- TRUE
}
invisible(ret)
},
parse_headers = function(headers,env){
hlines <- strsplit(rawToChar(headers),'\n')[[1]]
lapply(
strsplit(hlines,': '),
function(x) {
assign(
paste('HTTP_',gsub('-','_',gsub('(\\w+)','\\U\\1',x[1],perl=TRUE)),sep=''),
x[2],
env
)
}
)
},
build_env = function(appPath,path,query,postBody,headers){
env <- new.env(hash=TRUE,parent=emptyenv())
parse_headers(headers,env)
# remove HTTP_ from content length and type
if (exists('HTTP_CONTENT_LENGTH',env) && exists('HTTP_CONTENT_TYPE',env)){
assign('CONTENT_LENGTH',env$`HTTP_CONTENT_LENGTH`,env)
assign('CONTENT_TYPE',env$`HTTP_CONTENT_TYPE`,env)
rm('HTTP_CONTENT_LENGTH','HTTP_CONTENT_TYPE',envir=env)
}
assign('SCRIPT_NAME',appPath,env)
assign('PATH_INFO',sub(appPath,'',path,fixed=TRUE),env)
# The R internal web server unescapes the query, so in order
# abid the Rook spec, we have to do things in reverse:
#
# escape the query object so that subsequent URI building
# methods will add the correct query string.
assign('QUERY_STRING',
ifelse(is.null(query),
'',
paste(names(query),Utils$escape(query),sep='=',collapse='&')
),
env
)
if(exists("HTTP_REQUEST_METHOD", env)){
assign('REQUEST_METHOD',get("HTTP_REQUEST_METHOD", env) ,env)
} else {
assign('REQUEST_METHOD',ifelse(is.null(postBody),'GET','POST'),env)
}
hostport <- strsplit(get('HTTP_HOST',env),':',fixed=TRUE)[[1]]
assign('SERVER_NAME',hostport[1],env)
assign('SERVER_PORT',hostport[2],env)
assign('rook.version',packageDescription('Rook',fields='Version'),env)
assign('rook.url_scheme','http',env)
assign('rook.input',RhttpdInputStream$new(postBody),env)
assign('rook.errors',RhttpdErrorStream$new(),env)
if (debug()>1)
str(as.list(env))
env
},
handler = function(appName,path,query,postBody,headers){
if (debug()>0){
cat('Request:',path,'\n')
}
app <- appList[[appName]]
if (is.null(app)){
base::stop("No app installed named ",appName)
return()
}
if (!is.null(app$appEnv)){
file_path = app$appEnv$.appFile
mtime <- as.integer(file.info(file_path)$mtime)
if (mtime > app$appEnv$.mtime){
add(name=appName,app=file_path)
}
app <- appList[[appName]]
if (is.null(app)){
stop("No app installed named ",appName)
return()
}
oldwd <- setwd(dirname(app$appEnv$.appFile))
on.exit(setwd(oldwd))
}
env <- build_env(app$path,path,query,postBody,headers)
if (is(app$app,'function')) {
res <- try(app$app(env))
} else {
res <- try(app$app$call(env))
}
if (inherits(res,'try-error') || (is.character(res) && length(res) == 1))
res
else {
# Only need to handle the case where body is a vector of strings
# We presume that if res$body is a location to a file then the
# app has so named it. We also presume that res$body may be
# a raw vector, but we let the internal web server deal with that.
if (is.character(res$body) && length(res$body) > 1){
res$body <- paste(res$body,collapse='')
}
contentType <- res$headers$`Content-Type`;
res$headers$`Content-Type` <- NULL;
# The internal web server expects a list like the below,
# and the position of each element is important.
ret <- list(
payload = res$body,
`content-type` = contentType,
headers = NULL,
`status code` = res$status
)
# Change the name of payload to file in the case that
# payload *is* a filename
if (!is.null(names(res$body)) && names(res$body)[1] == 'file'){
names(ret) <- c('file',names(ret)[-1])
}
# Rhttpd doesn't allow Content-Length in the headers, so delete
# it as well
res$headers$`Content-Length` <- NULL;
if (length(res$headers)>0){
ret$headers <- paste(names(res$headers),': ',res$headers,sep='')
}
if (debug()>0){
cat('Response:\n')
str(ret)
}
ret
}
},
print = function() {
if (listenPort > 0){
cat("Server started on ",listenAddr,":",listenPort,"\n",sep='')
} else {
cat("Server stopped\n")
}
if (length(appList) == 0){
cat("No applications installed\n")
return(invisible())
}
len <- max(nchar(names(appList)))
for (i in 1:length(appList)){
appName <- sprintf(paste('%-',len,'s',sep=''),names(appList)[i])
cat('[',i,'] ',appName,' ',full_url(i),'\n',sep='')
}
cat("\nCall browse() with an index number or name to run an application.\n")
invisible()
},
show = function() print(),
debug = function(){
d <- getOption('Rhttpd_debug')
if (!is.null(d)) as.integer(d)
else 0
}
)
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.