Rook/0000755000175100001440000000000012421241716011202 5ustar hornikusersRook/inst/0000755000175100001440000000000012332170455012161 5ustar hornikusersRook/inst/servers/0000755000175100001440000000000012332170455013652 5ustar hornikusersRook/inst/servers/rApache.R0000644000175100001440000001127312332170455015344 0ustar hornikusers.rApacheInputStream <- setRefClass( 'rApacheInputStream', methods = list( read_lines = function(n = -1L){ if (n<=0) return(character()) readLines(n=n,warn=FALSE) }, read = function(l = -1L){ receiveBin(l) }, rewind = function(){ warning("rApache doesn't support rewind()") } ) ) .rApacheErrorStream <- setRefClass( 'rApacheErrorStream', methods = list( flush = function() { base::flush(stderr()) }, cat = function(...,sep=" ",fill=FALSE,labels=NULL) { base::cat(...,sep=sep,fill=fill,labels=labels,file=stderr()) } ) ) Server <- setRefClass( 'rApacheServer', fields = c('appPath','appList'), methods = list( initialize = function(...){ callSuper(...) }, AppPath = function(appPath){ if (length(appList) == 0) return() appPath <<- appPath }, build_env = function(){ env <- new.env(hash=TRUE,parent=emptyenv()) lapply(names(SERVER$headers_in),function(h){ assign( paste('HTTP_',gsub('-','_',gsub('(\\w+)','\\U\\1',h,perl=TRUE)),sep=''), SERVER$headers_in[[h]], env) }) if (exists('HTTP_CONTENT_LENGTH',env)) assign('CONTENT_LENGTH',get('HTTP_CONTENT_LENGTH',env),env) else assign('CONTENT_LENGTH',SERVER$clength,env) if (exists('HTTP_CONTENT_TYPE',env)) assign('CONTENT_TYPE',get('HTTP_CONTENT_TYPE',env),env) else assign('CONTENT_TYPE',SERVER$content_type,env) assign('SCRIPT_NAME',SERVER$cmd_path,env) assign('PATH_INFO',sub(SERVER$cmd_path,'',SERVER$uri),env) # Ensure only one leading forward slash env$PATH_INFO <- sub('^/+','/',env$PATH_INFO) assign('QUERY_STRING',SERVER$args,env) assign('QUERY_STRING',ifelse(is.null(SERVER$args),'',SERVER$args),env) assign('REQUEST_METHOD',SERVER$method,env) assign('REMOTE_HOST',SERVER$remote_host,env) assign('REMOTE_ADDR',SERVER$remote_ip,env) hostport <- strsplit(get('HTTP_HOST',env),':',fixed=TRUE)[[1]] assign('SERVER_NAME',hostport[1],env) if ('port' %in% names(SERVER)) assign('SERVER_PORT',SERVER$port,env) else assign('SERVER_PORT',hostport[2],env) assign('rook.version',packageDescription('Rook',fields='Version'),env) assign('rook.url_scheme', ifelse(isTRUE(SERVER$HTTPS),'https','http'),env) assign('rook.input',.rApacheInputStream$new(),env) assign('rook.errors',.rApacheErrorStream$new(),env) env }, call = function(app){ if (is(app,'refClass')) res <- try(app$call(build_env())) else if (is(app,'function')) res <- try(app(build_env())) else stop('App not Rook aware') if (inherits(res,'try-error')){ warning('App returned try-error object') return(HTTP_INTERNAL_SERVER_ERROR) } setStatus(res$status) setContentType(res$headers$`Content-Type`) res$headers$`Content-Type` <- NULL lapply(names(res$headers),function(n)setHeader(n,res$headers[[n]])) # If body is named, then better be a file. if (!is.null(names(res$body)) && names(res$body)[1] == 'file'){ sendBin(readBin(res$body[1],'raw',n=file.info(res$body[1])$size)) } else { if ((is.character(res$body) && nchar(res$body)>0) || (is.raw(res$body) && length(res$body)>0) ) sendBin(res$body) } OK } ) )$new() Request$methods( GET = function(){ if (!exists('rook.request.query_list',env)) env[['rook.request.query_list']] <<- base::get('GET','rapache') env[['rook.request.query_list']] }, POST = function() { if (exists('rook.request.form_list',env)) return(env[['rook.request.form_list']]) postvar <- base::get('POST','rapache') filevar <- base::get('FILES','rapache') if (length(postvar) <= 0 && length(filevar) <= 0) return(NULL) if (length(filevar) > 0){ if (length(postvar) <= 0) postvar <- list() for (n in names(filevar)){ if (length(filevar[[n]])>0){ postvar[[n]] <- list( filename = filevar[[n]]$name, tempfile = filevar[[n]]$tmp_name, content_type = Mime$mime_type(Mime$file_extname(filevar[[n]]$name)) ) } } } for (n in names(postvar)){ if (is.null(postvar[[n]])) postvar[[n]] <- NULL } env[['rook.request.form_list']] <<- postvar postvar } ) Rook/inst/exampleApps/0000755000175100001440000000000012332170455014440 5ustar hornikusersRook/inst/exampleApps/RookTestApp.R0000644000175100001440000000314012332170455016774 0ustar hornikusersapp <- function(env){ req <- Request$new(env) res <- Response$new() envstr <- paste(capture.output(str(as.list(env)),file=NULL),collapse='\n') poststr <- paste(capture.output(str(req$POST()),file=NULL),collapse='\n') getstr <- paste(capture.output(str(req$GET()),file=NULL),collapse='\n') randomString <- function() paste(letters[floor(runif(10,0,26))],collapse='') randomNumber <- function() runif(1,0,26) res$write( c( '', 'rook logo', '

Welcome to Rook

\n', sprintf('
',env$SCRIPT_NAME,randomString(),randomNumber()), 'Enter a string:
\n', 'Enter another string:
\n', 'Upload a file:
\n', 'Upload another file:
\n', '

', 'Environment:
',envstr,'

', 'Get:
',getstr,'

', 'Post:
',poststr, '


' )) res$finish() } Rook/inst/exampleApps/helloworld.R0000644000175100001440000000070412332170455016737 0ustar hornikusersapp <- function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() friend <- 'World' if (!is.null(req$GET()[['friend']])) friend <- req$GET()[['friend']] res$write(paste('

Hello',friend,'

\n')) res$write('What is your name?\n') res$write('\n') res$write('\n') res$write('\n
\n
') res$finish() } Rook/inst/exampleApps/helloworldref.R0000644000175100001440000000035012332170455017431 0ustar hornikusersapp <- setRefClass( 'HelloWorld', methods = list( call = function(env){ list( status=200, headers = list( 'Content-Type' = 'text/html' ), body = paste('

Hello World!

') ) } ) )$new() Rook/inst/exampleApps/rnorm.R0000644000175100001440000000211712332170455015721 0ustar hornikusersapp <- Builder$new( URLMap$new( '^/.*\\.html$' = function(env){ req <- Request$new(env) res <- Response$new() if (is.null(req$GET()$n)){ n <- 100 } else { n <- as.integer(req$GET()$n) } res$write('How many squares?\n') res$write('
\n') res$write(sprintf('\n',n)) res$write('\n
\n
') if (n>0){ res$write(paste('',sep='')) } res$finish() }, '^/.*\\.png$' = function(env){ req <- Request$new(env) res <- Response$new() res$header('Content-type','image/png') if (is.null(req$GET()$n)){ n <- 100 } else { n <- as.integer(req$GET()$n) } t <- tempfile() png(file=t) png(t,type="cairo",width=200,height=200) par(mar=rep(0,4)) plot(rnorm(n),col=rainbow(n,alpha=runif(n,0,1)),pch='.',cex=c(2,3,4,5,10,50)) dev.off() res$body <- t names(res$body) <- 'file' res$finish() }, '.*' = Redirect$new('/index.html') ) ) Rook/inst/exampleApps/exampleData/0000755000175100001440000000000012332170455016665 5ustar hornikusersRook/inst/exampleApps/exampleData/index.html0000644000175100001440000000135612332170455020667 0ustar hornikusers R Dataset Explorer

R Dataset Explorer with Rook

This example demonstrates Rook by exploring the R datasets package. Each dataset is presented below. By clicking on one, you will be able to explore the dataset with a plot or by returning the dataset in its entirety as a JSON object.

<% counter <- 0 numcols <- 6 for (i in sort(ls('package:datasets'))){ if (counter %% numcols == 0) cat("") %> <% counter <- counter + 1; } %>
<%=i%> [ json] [ png]
Rook/inst/exampleApps/exampleData/error.html0000644000175100001440000000011512332170455020701 0ustar hornikusers

ERROR! <%=dataset%> not found.

Rook/inst/exampleApps/exampleData/config.R0000644000175100001440000001174412332170455020264 0ustar hornikuserslibrary(datasets) library(RJSONIO) render_json <- function(object) { # Some objects are instances of a sub-class of data.frame # and RJSONIO doesn't know what to do with them, so we just # use trickery. if (inherits(object,'data.frame',which = TRUE) > 0){ class(object) <- 'data.frame' # Even these may have ts objects as columns so lets # just punt for right now and assign it an NA column. for (i in names(object)){ if (inherits(object[[i]],'ts')){ object[[i]] <- NA } } } # Unclassing here is unclassy. Would be nice to use as.data.frame # but it seems that the original ts object is stuffed into the result # somehow. if (inherits(object,'ts')){ object <- unclass(object) } if (inherits(object,'table') || inherits(object,'array')){ object <- as.data.frame(object) } RJSONIO::toJSON(object) } app <- Builder$new( Brewery$new(url='.*\\.html$',root='.'), URLMap$new( '^/.*\\.csv$' = function(env){ req <- Request$new(env) res <- Response$new() datasets <- ls('package:datasets') tmpdataset <- sub('^/(.*)\\.csv','\\1',req$path_info()) dataset <- datasets[datasets %in% tmpdataset][1] if (is.na(dataset)) dataset <- 'iris' res$header('Content-type','text/csv') res$write( paste( capture.output(eval(parse(text=sprintf('write.csv(%s)',dataset)))), collapse="\n" ) ) res$finish() }, '^/.*\\.json$' = function(env){ req <- Request$new(env) res <- Response$new() datasets <- ls('package:datasets') tmpdataset <- sub('^/(.*)\\.json','\\1',req$path_info()) dataset <- datasets[datasets %in% tmpdataset][1] if (is.na(dataset)) dataset <- 'iris' res$header('Content-type','application/json') res$write(eval(parse(text=sprintf('render_json(%s)',dataset)))) res$finish() }, '^/.*\\.png$' = function(env){ req <- Request$new(env) res <- Response$new() datasets <- ls('package:datasets') tmpdataset <- sub('^/(.*)\\.csv','\\1',req$path_info()) dataset <- datasets[datasets %in% tmpdataset][1] if (is.na(dataset)) dataset <- 'iris' res$finish() }, '.*' = Redirect$new('/index.html') ) ) ############################################ ## Top level HTML pages ############################################ # #render_brew <- function(template, params = list(), path = getwd()) { # if (is.list(params)) { # env <- new.env(TRUE) # for(name in names(params)) { # env[[name]] <- params[[name]] # } # params <- env # } # # path <- file.path(path, "views", stringr::str_c(template, ".html")) # if (!file.exists(path)) stop("Can not find ", template, " template ", # call. = FALSE) # setContentType('text/html') # brew::brew(path, envir = params) # OK #} # #router$get("/", function(...) { # # brews the file index.html in the /views dir # render_brew("index",list(...)) #}) # ## This is the RESTful part of the application. Each ## dataset found in the datasets package has its own ## URL #router$get("/dataset/:dataset.html", function(dataset) { # if (any(ls('package:datasets') == dataset)) # render_brew("dataset",list(dataset=dataset)) # else # render_brew("error",list(dataset=dataset)) #}) # #router$get("/dataset/:dataset.csv", function(dataset) { # setContentType('text/csv') # eval(parse(text=paste('write.csv(',dataset,',file=stdout())'))) # OK #}) # # # ############################################ ## Web services ############################################ # #router$get('/dataset/:dataset.json', function(dataset){ # if (!any(ls('package:datasets') == dataset)) # render_brew("error",list(dataset=dataset)) # else # render_json(get(dataset)) #}) # ## Returned when no dataset's example renders a plot #bad_plot <- function(dataset){ # t <- tempfileWithExtension() # png(t) # #par(mar=rep(0,4)) # plot(rnorm(100),main=paste('Fail for',dataset,' but Check it!'),col=rainbow(100,alpha=runif(100,0,1)),pch='.',cex=c(2,3,4,5,10,50,100)) # dev.off() # payday <- readBin(t,'raw',file.info(t)$size) # unlink(t) # payday #} # #router$get('/dataset/:dataset.png', function(dataset){ # # if (!any(ls('package:datasets') == dataset)) # render_brew("error",list(dataset=dataset)) # # setContentType('image/png') # # t <- tempfileWithExtension() # #cat('tempfile is',t,'\n') # png(t) # # # This is a bit of magic. R has an example function # # which runs example code located at the end of a # # particular help topic. Fortunately, there's a help # # topic for all datasets exported from the 'datasets' # # package. Unfortunately, not all of them produce a plot, # # and they can be noisy. # # # # This is where you would place your own data and plot routines, FYI # # # capture.output( # suppressWarnings( # eval( # substitute( # example(dataset,package='datasets',ask=FALSE), # list(dataset=dataset) # ) # ) # )) # # # dev.off() # payday <- try(readBin(t,'raw',file.info(t)$size)) # unlink(t) # # if (inherits(payday,'try-error') || length(payday) <=1 ){ # payday <- bad_plot(dataset) # } # # sendBin(payday) # # OK #}) # Rook/inst/exampleApps/exampleData/dataset.html0000644000175100001440000000114112332170455021175 0ustar hornikusers<% datasets <- ls('package:datasets') dataset <- datasets[datasets %in% req$GET()[['data']]][1] if (is.na(dataset)) dataset <- 'iris' %>

<%=dataset%> Summary

<%=paste(capture.output(eval(parse(text=sprintf("summary(%s)",dataset)))),collapse='
')%>

Click on the below:

Rook/inst/exampleApps/Hmisc/0000755000175100001440000000000012332170455015503 5ustar hornikusersRook/inst/exampleApps/Hmisc/images/0000755000175100001440000000000012332170455016750 5ustar hornikusersRook/inst/exampleApps/Hmisc/images/spinner.gif0000644000175100001440000000376512332170455021130 0ustar hornikusersGIF89a鵵<<<򭭭۪׻&&&عˮRRRꅅJJJ Ѥ)))]]]̷YYYfffʦุzzzNNNjjjֺnnnޖaaatttTTTFFFWWW222www|||666qqqAAAlllxxx---###Ҭ! NETSCAPE2.0!,Ȁ-h _W -%Mo>j`=^:Q!6 53p6ZO/Q,);Q  G@l^ba"-$ R:σ1?T"!J `Ą%* ċl4HDa+Q4\"  RaVg @!, otp8_sZ7L2>ngwhP7'tbcAr.: *2rb"K[\,A?B= M"- aɊH!1?!,d d=befN>]Ic.lF61 Zb3gA#Mc_XdE7k_$17|yC,FwWmZ'/zR[ #VQ!,b -%#!2;/ZY!Nqjc6#Pb,O e5.=P_veVf*gJ&moo6dKq$>|`͇)" !, m#=!2;/2Y!6  O!G#H;2^^H+c3d;JqBfEfZ!_m*.G>Sg<(hSkRPp!, rB1 OD,U  GM& !R ,D(HmzP 2-FbnG}5Z`ch+3!DIe/;cZ !, dV,P33fA}EmE"-,$Cd{u?F|e=b 2(],G3K!j%y[_t e?QF+H5"0(). !, rO:!2;>W."X2Y!Ml|sN1d^X_pxk7hG% HmFnS. CCJ]PL6^j?#V5' +)!,a :8oC|u(U! 3s hP'X*h^;edj%dXXg(D)nePI~q='/$ ;Rook/inst/exampleApps/Hmisc/css/0000755000175100001440000000000012332170455016273 5ustar hornikusersRook/inst/exampleApps/Hmisc/css/useR2007.css0000644000175100001440000000344012332170455020235 0ustar hornikusersbody { font: .7em verdana, arial, sans-serif; margin-top: 10px; margin-left:10px; margin-right:10px; /* border: 1px solid black; */ } /* img { border: 1px; position: absolute; } */ * {margin:0; padding:0;} div#mainwrapper { /* min-width:760px; */ /* max-width:880px; */ margin-left:auto; margin-right:auto;} /* centers layout when > max width */ div#header { width:auto; } #threecolwrap { float:left; width:100%; } #twocolwrap { float:left; width:100%; display:inline; /* stops IE doubling margin on float*/ margin-right:-170px; /* CWS - neg margin move */ } #leftcol { float:left; width:175px; display:inline; /* stops IE doubling margin on float*/ /* border: 1px solid black; */ } #content { width:600px; margin-left:175px; margin-top: 0px; /* margin-right:170px; */ /* border: 1px solid black; */ } #rightcol { position: absolute; width:175px; margin-left: 775px; /* width:170px; */ /* width: auto;*/ /* border: 1px solid black; */ } #footer { width:100%; clear:both; float:left; text-align: right; font-size: .6em; /* border: 1px solid black; */ } div#yldiv { float:left; width:250px; display: none; } select { /* float: right; */ width: 100%; font-size: .9em; border: 1px solid grey; } div#formcontent { /*border: 1px solid black; */ } div.clearfix { /* border: 1px solid #CCC; */ margin-bottom: 10px; } label { float: left; font-size: .9em; font-weight: bold; width:100% } div#content h1,h2,h3 { text-align: center } div#content p,ul { margin: 2% 20% 2% 20%; font-size: 1.2em; } div#content li { margin-bottom: 3%; } div#showpdf { margin-left: 20px; } div#copyright { color: grey; text-align: center; font-size: .8em; margin: 10% 20% 0px 20%; } div#bibliography { margin-top: 10px; font: .8em verdana, arial, sans-serif; font-weight: bold; } Rook/inst/exampleApps/Hmisc/config.R0000644000175100001440000000056612332170455017102 0ustar hornikuserslibrary(Hmisc) dir.create(file.path(tempdir(),'plots'),showWarnings=FALSE) app <- Builder$new( Static$new( urls = c('/css','/images','/javascript'), root = '.' ), Static$new(urls='/plots',root=tempdir()), Brewery$new( url='/brew', root='.', imagepath=file.path(tempdir(),'plots'), imageurl='../plots/' ), Redirect$new('/brew/useR2007.rhtml') ) Rook/inst/exampleApps/Hmisc/javascript/0000755000175100001440000000000012332170455017651 5ustar hornikusersRook/inst/exampleApps/Hmisc/javascript/useR2007.js0000644000175100001440000000114612332170455021440 0ustar hornikusersfunction RePlot(){ var p1 = document.spower.p1.value; var p2 = document.spower.p2.value; var mo = document.spower.mo.value; new Ajax.Updater( 'plot', 'useR2007plot.rhtml', { 'method': 'get', 'parameters': {'p1': p1, 'p2': p2, 'mo': mo}, } ); } function ReSimulate(){ var p1 = document.spower.p1.value; var p2 = document.spower.p2.value; var mo = document.spower.mo.value; Element.show('spinner'); new Ajax.Updater( 'spowerResult', 'useR2007sim.rhtml', { 'method': 'get', 'parameters': {'p1': p1, 'p2': p2, 'mo': mo}, 'onSuccess': function(r){Element.hide('spinner')} } ); } Rook/inst/exampleApps/Hmisc/brew/0000755000175100001440000000000012332170455016442 5ustar hornikusersRook/inst/exampleApps/Hmisc/brew/useR2007plot.rhtml0000644000175100001440000000143612332170455021644 0ustar hornikusers Rook/inst/exampleApps/Hmisc/brew/useR2007.rhtml0000644000175100001440000000642512332170455020750 0ustar hornikusers Brewing with Rapache: useR2007 example with Hmisc

Power and Sample Size Calculations with spower from Hmisc

The following example[1] demonstrates the flexibility of spower and related functions from Hmisc. We simulate a 2-arm (350 subjects/arm) 5-year follow-up study for wich the control group's survival distribution is Weibull with 1-year survival of .95 and 3-year survival of .7. All subjects are followed at least one year, and patients enter the study with linearly increasing probability starting with zero. Assume (1) there is no chance of dropin for the first 6 months, then the probability increases linearly up to .15 at 5 years; (2) there is a linearly increasing chance of dropout up to .3 at 5 years; and (3) the treatment has no effect for the first 9 months, then it has a constant effect (hazard ratio of .75).

[1] Alzola CF, Harrell FE: An Introduction to S and the Hmisc and Design Libraries. Freely available electronic book.



Jeffrey Horner
Hmisc
brew
Cairo
rapache
<% brew('useR2007plot.rhtml') %>
Characteristics of control and intervention groups with a lag in the treatment effect and with non-compliance in two directions.
Rook/inst/exampleApps/Hmisc/brew/useR2007sim.rhtml0000644000175100001440000000130412332170455021450 0ustar hornikusers<% GET <- req$GET() p1 <- ifelse(is.null(GET$p1),.95,as.numeric(GET$p1)) p2 <- ifelse(is.null(GET$p2),.7,as.numeric(GET$p2)) mo <- ifelse(is.null(GET$mo),9,as.numeric(GET$mo)) options(hverbose=FALSE,verbose=FALSE) t <- tempfile() sink(t) library(Hmisc) sc <- Weibull2(c(1,3),c(p1,p2)) f <- Quantile2(sc, hratio=function(x) ifelse(x <= mo/12, 1, .75), dropin=function(x) ifelse(x <= .5, 0, .15 * (x-.5)/(5-.5)), dropout=function(x) .3*x/5 ) rcens <- function(n) 1 + (5-1) * (runif(n) ^ .5) rcontrol <- function(n) f(n,'control') rinterv <- function(n) f(n,'intervention') set.seed(211) x <- spower(rcontrol,rinterv,rcens, nc=350, ni=350, test=logrank, nsim=300) sink() unlink(t) %> <%=format(x,digits=5)%> Rook/inst/exampleApps/summary.R0000644000175100001440000000144112332170455016260 0ustar hornikusersapp <- function(env) { req <- Rook::Request$new(env) res <- Rook::Response$new() res$write('Choose a CSV file:\n') res$write('
\n') res$write('\n') res$write('\n
\n
') if (!is.null(req$POST())){ data <- req$POST()[['data']] res$write("

Summary of Data

"); res$write("
")
	res$write(paste(capture.output(summary(read.csv(data$tempfile,stringsAsFactors=FALSE)),file=NULL),collapse='\n'))
	res$write("
") res$write("

First few lines (head())

"); res$write("
")
	res$write(paste(capture.output(head(read.csv(data$tempfile,stringsAsFactors=FALSE)),file=NULL),collapse='\n'))
	res$write("
") } res$finish() } Rook/inst/exampleApps/arrayparams.R0000644000175100001440000000360512332170455017111 0ustar hornikusersapp <- function(env){ req <- Request$new(env) res <- Response$new() getVars <- req$GET() postVars <- req$POST() content <- c("\n", "\n\nRook Array Parameters\n\n", "\n

Rook Array Parameters

\n", "

GET request

\n
\n

\n", "\n", "\n", "

\n

\n\n

\n
\n") if (length(getVars) > 0) { content <- c(content, "
\n",
        paste(capture.output(str(getVars), file=NULL), collapse='\n'),
        "
\n") } content <- c(content, "

POST request

\n
\n

\n", "\n", "\n", "

\n

\n\n

\n
\n") if (length(postVars) > 0 && 'post' %in% names(postVars)) { content <- c(content, "
\n",
        paste(capture.output(str(postVars), file=NULL), collapse='\n'),
        "
\n") } content <- c(content, "

POST multipart request

\n
\n

\n", "\n", "\n", "

\n

\n\n

\n
\n") if (length(postVars) > 0 && 'multipart' %in% names(postVars)) { content <- c(content, "
\n",
        paste(capture.output(str(postVars), file=NULL), collapse='\n'),
        "
\n") } res$write(c(content, "\n\n")) res$finish() } Rook/inst/exampleApps/RJSONIO.R0000644000175100001440000000246712332170455015717 0ustar hornikuserslibrary(Rook) library(RJSONIO) app <- function(env){ req <- Request$new(env) res <- Response$new() obj <- sub('^/','',req$path_info()) # Get out of here fast if no object exists if (!exists(obj)) return(res$finish()) # res$write(paste(capture.output(str(req$params()),file=NULL),collapse='\n')) # return(res$finish()) # Gather args from one of three sources: GET, POST as a x-www-urlencoded, # or POST as JSON payload. params() squishes GET and POST together when # POST is x-www-urlencoded. if (!is.null(req$params())) { args <- req$params() } else { # TODO: Collect POST payload and pass to RJSONIO args <- list() } # Normalize arguments to R types if necessary. Integers to integer, Numerics to numeric, etc. # Maybe we can propose a vector syntax in CGI that's coherent, too. for (i in names(args)){ # Keep as character anything that starts with a quote char if (grepl('^[\'"]',args[[i]])) next # Integer if (grepl('^[+-]?\\d+$',args[[i]])) args[[i]] <- as.integer(args[[i]]) # Numeric. need to add scientific notation if (grepl('^[+-]?[0-9.]+$',args[[i]])) args[[i]] <- as.numeric(args[[i]]) } if (is.function(get(obj))) res$write(toJSON(do.call(obj,args))) else res$write(toJSON(get(obj))) res$finish() } Rook/src/0000755000175100001440000000000012421237102011763 5ustar hornikusersRook/src/rook.c0000644000175100001440000000301312421237107013103 0ustar hornikusers#include #include #include SEXP rawmatch( SEXP needle, SEXP haystack, SEXP allMatches){ int i, j, k, n1, n2; Rbyte *x1, *x2; Rboolean all; SEXP ans, newans; if (TYPEOF(haystack) == RAWSXP){ n1 = LENGTH(haystack); x1 = RAW(haystack); } else error_return("haystack must be a raw vector"); if (isString(needle)){ n2 = LENGTH(STRING_ELT(needle,0)); x2 = (Rbyte *) CHAR(STRING_ELT(needle,0)); } else if (TYPEOF(needle) == RAWSXP){ n2 = LENGTH(needle); x2 = RAW(needle); } else error_return("needle must be a character or raw vector"); if (!isLogical(allMatches)) error_return("all must be a logical vector") all = LOGICAL(allMatches)[0]; if (n2 > n1) return allocVector(INTSXP,0); k = 0; ans = allocVector(INTSXP, all? (int)(n1 / n2) : 1); for (i = 0; i < n1; i++){ if (x1[i] == x2[0]){ for (j = 0; j < n2; j++){ if (x1[i+j] != x2[j]) break; } if (j==n2){ INTEGER(ans)[k++] = i + 1; if (!all) return ans; } } } if (k == LENGTH(ans)) return ans; newans = allocVector(INTSXP,k); while(k) {k--;INTEGER(newans)[k] = INTEGER(ans)[k];} return newans; } R_CallMethodDef callMethods[] = { {"rawmatch", (DL_FUNC) &rawmatch, 3}, {NULL, NULL, 0} }; void R_init_Rook(DllInfo *info) { R_registerRoutines(info, NULL, callMethods, NULL, NULL); /* R_useDynamicSymbols(info, FALSE);*/ } Rook/NAMESPACE0000644000175100001440000000104412332171657012427 0ustar hornikusersexportClass(Rhttpd,RhttpdApp,RhttpdInputStream,RhttpdErrorStream) export(Rhttpd,RhttpdApp,RhttpdInputStream,RhttpdErrorStream) exportClass(Utils,Multipart) export(Utils,Multipart) exportClass(Request,Response,Mime) export(Request,Response,Mime) exportClass(File,Static,Builder,App,Middleware,URLMap) export(File,Static,Builder,App,Middleware,URLMap) exportClass(Brewery,Redirect) export(Brewery,Redirect) export(is_rookable) export(Server,suspend_console) useDynLib(Rook,.registration=TRUE) import(tools) import(utils) import(methods) import(brew) Rook/R/0000755000175100001440000000000012421230533011376 5ustar hornikusersRook/R/utils.R0000644000175100001440000005224012332170455012673 0ustar hornikusersUtils <- setRefClass( 'Utils', fields = c( 'HTTP_STATUS_CODES', 'STATUS_WITH_NO_ENTITY_BODY', 'CHAR_TO_STATUS_CODE', 'DEFAULT_SEP' ), methods = list( initialize = function(...){ HTTP_STATUS_CODES <<- new.env(hash=TRUE) # Generated with: # curl -s http://www.iana.org/assignments/http-status-codes | \ # ruby -ane 'm = /^(\d{3}) +(\S[^\[(]+)/.match($_) and # puts " `#{m[1]}` <- \x27#{m[2].strip}\x27"' with(HTTP_STATUS_CODES,{ `100` <- 'Continue' `101` <- 'Switching Protocols' `102` <- 'Processing' `200` <- 'OK' `201` <- 'Created' `202` <- 'Accepted' `203` <- 'Non-Authoritative Information' `204` <- 'No Content' `205` <- 'Reset Content' `206` <- 'Partial Content' `207` <- 'Multi-Status' `208` <- 'Already Reported' `226` <- 'IM Used' `300` <- 'Multiple Choices' `301` <- 'Moved Permanently' `302` <- 'Found' `303` <- 'See Other' `304` <- 'Not Modified' `305` <- 'Use Proxy' `306` <- 'Reserved' `307` <- 'Temporary Redirect' `400` <- 'Bad Request' `401` <- 'Unauthorized' `402` <- 'Payment Required' `403` <- 'Forbidden' `404` <- 'Not Found' `405` <- 'Method Not Allowed' `406` <- 'Not Acceptable' `407` <- 'Proxy Authentication Required' `408` <- 'Request Timeout' `409` <- 'Conflict' `410` <- 'Gone' `411` <- 'Length Required' `412` <- 'Precondition Failed' `413` <- 'Request Entity Too Large' `414` <- 'Request-URI Too Long' `415` <- 'Unsupported Media Type' `416` <- 'Requested Range Not Satisfiable' `417` <- 'Expectation Failed' `422` <- 'Unprocessable Entity' `423` <- 'Locked' `424` <- 'Failed Dependency' `425` <- 'Reserved for WebDAV advanced' `426` <- 'Upgrade Required' `500` <- 'Internal Server Error' `501` <- 'Not Implemented' `502` <- 'Bad Gateway' `503` <- 'Service Unavailable' `504` <- 'Gateway Timeout' `505` <- 'HTTP Version Not Supported' `506` <- 'Variant Also Negotiates' `507` <- 'Insufficient Storage' `508` <- 'Loop Detected' `509` <- 'Unassigned' `510` <- 'Not Extended' }) STATUS_WITH_NO_ENTITY_BODY <<- as.integer(c(100:199,204,304)) CHAR_TO_STATUS_CODE <<- new.env(hash=TRUE) lapply(names(as.list(HTTP_STATUS_CODES)),function(x){ code <- as.integer(x) assign(x,code,CHAR_TO_STATUS_CODE) assign(gsub(' ','_',tolower(HTTP_STATUS_CODES[[x]])),code,CHAR_TO_STATUS_CODE) }) DEFAULT_SEP <<- '[&;] *' callSuper(...) }, escape = function(s=NULL) { if (is.null(s)) base::stop("Need a character vector argument") unlist(lapply(s,function(s){ x <- strsplit(s,"")[[1L]] z <- grep('[^ a-zA-Z0-9_.-]',x,perl=TRUE) if (length(z)){ y <- sapply(x[z],function(i) paste('%',paste(toupper(as.character(charToRaw(i))),collapse='%'),sep='')) x[z] <- y } s <- paste(x,collapse='') chartr(' ','+',s) })) }, unescape = function(s=NULL){ if(is.null(s)) base::stop("Need a character vector argument") unlist(lapply(s,function(s) utils::URLdecode(chartr('+',' ',s)) )) }, parse_query = function(qs=NULL, d=DEFAULT_SEP) { if (is.null(qs)) base::stop("Need a character vector argument") x <- strsplit(qs,d,perl=TRUE)[[1L]] if (length(x) == 0) return(list()) z <- x != '' params <- new.env() params$params <- list() if (length(z)){ parseEqual <- function(i,params){ m <- regexpr('=',i)[1L] if (m > 0){ if (m == 1){ params$params[['']] <- unescape(i) } else { ilen <- nchar(i) if (m == ilen){ params$params[[i]] <- '' } else { # handle array parameters paramName <- substr(i,1,m-1) paramValue <- unescape(substr(i,m+1,ilen)) paramSet <- FALSE if (grepl("\\[\\]$", paramName)) { paramName <- sub("\\[\\]$", "", paramName) if (paramName %in% names(params$params)) { params$params[[paramName]] <- c(params$params[[paramName]], paramValue) paramSet <- TRUE } } if (!paramSet) { params$params[[paramName]] <- paramValue } } } } else { params$params[[i]] <- NA } } lapply(x[z],parseEqual,params) } params$params }, #parse_nested_query = function() {}, #normalize_params = function () {}, build_query = function(params=NULL) { if (is.null(params)) base::stop("Need named list argument") # TODO: call escape here, need to vectorize it first paste(names(params),params,sep='=',collapse='&') }, #build_nested_query = function() {}," escape_html = function(string=NULL) { if (is.null(string)) base::stop("Need a character vector argument") string <- gsub('&','&',string) string <- gsub('<','<',string) string <- gsub('>','>',string) string <- gsub("'",''',string) string <- gsub('"','"',string) string }, #selectBestEncoding = function(){}, set_cookie_header = function(header,key=NULL,value='',expires=NULL,path=NULL,domain=NULL,secure=FALSE,httpOnly=FALSE){ if (is.null(key)) return(invisible()) cookie <- paste( escape(key), paste(sapply(value,escape),collapse='&'), sep='=') if (!is.null(expires)) cookie <- paste(cookie,'; expires=',rfc2822(expires),sep='') if (!is.null(path)) cookie <- paste(cookie,'; path=',path,sep='') if (!is.null(domain)) cookie <- paste(cookie,'; domain=',domain,sep='') if (secure) cookie <- paste(cookie,'; secure',sep='') if (httpOnly) cookie <- paste(cookie,'; HttpOnly',sep='') if (is.null(header$`Set-Cookie`) || header$`Set-Cookie` == '') header$`Set-Cookie` <- cookie else header$`Set-Cookie` <- paste(header$`Set-Cookie`,cookie,sep='\n') }, delete_cookie_header = function(header,key=NULL,value='',expires=NULL,path=NULL,domain=NULL,secure=FALSE,httpOnly=FALSE){ if (is.null(header$`Set-Cookie`)) return(invisible()) cookies <- strsplit(header$`Set-Cookie`,'\n')[[1L]] if (length(cookies) == 0) return(invisible()) d <- ifelse(is.null(domain), grepl(paste('^',escape(key),'=',sep=''),cookies,perl=TRUE), grepl(paste('^',escape(key),'=.*domain=',domain,sep=''),cookies,perl=TRUE) ) header$`Set-Cookie` <- paste(cookies[!d],collapse='\n') set_cookie_header(header,key,'',timezero(),path,domain,secure,httpOnly) }, bytesize = function(string=NULL) { if (is.null(string)) base::stop("Need a character vector") nchar(string,type='bytes') }, raw.match = function(needle=NULL,haystack=NULL,all=TRUE) .Call(Rook:::rawmatch,needle,haystack,all), timezero = function() structure(0,class=c('POSIXct','POSIXt')), rfc2822 = function(ts=NULL){ if (is.null(ts) || !inherits(ts,'POSIXt')) base::stop("Need a POSIXt object") format(ts,format="%a, %d %b %Y %H:%M:%S GMT",tz='GMT') }, status_code = function(status=NULL){ if (is.null(status) || status == '') return(as.integer(500)) if(is.character(status)){ code <- try(get(gsub(' ','_',tolower(status)),CHAR_TO_STATUS_CODE,inherits=FALSE),silent=TRUE) ifelse(inherits(code,'try-error'),500,code) } else { as.integer(status) } } ) )$new() #UploadedFile <- setRefClass( # 'UploadedFile', #) Multipart <- setRefClass( 'Multipart', fields = c('EOL'), methods = list( initialize = function(...){ EOL <<- '\r\n' callSuper(...) }, parse = function(env){ if (!exists('CONTENT_TYPE',env)) return(NULL) # return value params <- list() input <- env$`rook.input` input$rewind() content_length = as.integer(env$CONTENT_LENGTH) # Bail if not a multipart content body if (!grepl('multipart',env$CONTENT_TYPE)) return(NULL) # Some constants regarding boundaries boundary <- paste('--',gsub('^multipart/.*boundary="?([^";,]+)"?','\\1',env$CONTENT_TYPE,perl=TRUE),sep='') boundary_size <- Utils$bytesize(boundary) boundaryEOL <- paste(boundary,EOL,sep='') boundaryEOL_size <- boundary_size + Utils$bytesize(EOL) EOLEOL = paste(EOL,EOL,sep='') EOLEOL_size = Utils$bytesize(EOLEOL) EOL_size = Utils$bytesize(EOL) buf <- new.env() buf$bufsize <- 16384 # Never read more than bufsize bytes. buf$read_buffer <- input$read(boundaryEOL_size) buf$read_buffer_len <- length(buf$read_buffer) buf$unread <- content_length - boundary_size i <- Utils$raw.match(boundaryEOL,buf$read_buffer,all=FALSE) if (!length(i) || i != 1){ warning("bad content body") input$rewind() return(NULL) } fill_buffer <- function(x){ buf <- input$read(ifelse(x$bufsize < x$unread, x$bufsize, x$unread)) buflen <- length(buf) if (buflen > 0){ x$read_buffer <- c(x$read_buffer,buf) x$read_buffer_len <- length(x$read_buffer) x$unread <- x$unread - buflen } } # Slices off the beginning part of read_buffer. slice_buffer <- function(i,size,x){ slice <- if(i > 1) x$read_buffer[1:(i-1)] else x$read_buffer[1] x$read_buffer <- if(size < x$read_buffer_len) x$read_buffer[(i+size):x$read_buffer_len] else raw() x$read_buffer_len <- length(x$read_buffer) slice } # prime the read_buffer buf$read_buffer <- raw() fill_buffer(buf) while(TRUE) { head <- value <- NULL filename <- content_type <- name <- NULL while(is.null(head)){ i <- Utils$raw.match(EOLEOL,buf$read_buffer,all=FALSE) if (length(i)){ head <- slice_buffer(i,EOLEOL_size,buf) break } else if (buf$unread){ fill_buffer(buf) } else { break # we've read everything and still haven't seen a valid head } } if (is.null(head)){ warning("Bad post payload: searching for a header") input$rewind() return(NULL) } # cat("Head:",rawToChar(head),"\n") # they're 8bit clean head <- rawToChar(head) token <- '[^\\s()<>,;:\\"\\/\\[\\]?=]+' condisp <- paste('Content-Disposition:\\s*',token,'\\s*',sep='') dispparm <- paste(';\\s*(',token,')=("(?:\\"|[^"])*"|',token,')*',sep='') rfc2183 <- paste('(?m)^',condisp,'(',dispparm,')+$',sep='') broken_quoted <- paste('(?m)^',condisp,'.*;\\sfilename="(.*?)"(?:\\s*$|\\s*;\\s*',token,'=)',sep='') broken_unquoted = paste('(?m)^',condisp,'.*;\\sfilename=(',token,')',sep='') if (length(grep(rfc2183,head,perl=TRUE))){ first_line <- sub(condisp,'',strsplit(head,'\r\n')[[1L]][1],perl=TRUE) pairs <- strsplit(first_line,';',fixed=TRUE)[[1L]] fnmatch <- '\\s*filename=(.*)\\s*' if (any(grepl(fnmatch,pairs,perl=TRUE))){ filename <- pairs[grepl(fnmatch,pairs,perl=TRUE)][1] filename <- gsub('"','',sub(fnmatch,'\\1',filename,perl=TRUE)) } } else if (length(grep(broken_quoted,head,perl=TRUE))){ filename <- sub(broken_quoted,'\\1',strsplit(head,'\r\n')[[1L]][1],perl=TRUE) } else if (length(grep(broken_unquoted,head,perl=TRUE))){ filename <- sub(broken_unquoted,'\\1',strsplit(head,'\r\n')[[1L]][1],perl=TRUE) } if (!is.null(filename) && filename!=''){ filename = Utils$unescape(filename) } headlines <- strsplit(head,EOL,fixed=TRUE)[[1L]] content_type_re <- '(?mi)Content-Type: (.*)' content_types <- headlines[grepl(content_type_re,headlines,perl=TRUE)] if (length(content_types)){ content_type <- sub(content_type_re,'\\1',content_types[1],perl=TRUE) } name <- sub('(?si)Content-Disposition:.*\\s+name="?([^";]*).*"?','\\1',head,perl=TRUE) while(TRUE){ i <- Utils$raw.match(boundary,buf$read_buffer,all=FALSE) if (length(i)){ value <- slice_buffer(i,boundary_size,buf) if (length(value)){ # Drop EOL only values if (length(value) == 2 && length(Utils$raw.match(EOL,value))) break if (!is.null(filename) || !is.null(content_type)){ data <- list() if (!is.null(filename)) data$filename <- strsplit(filename,'[\\/]',perl=TRUE)[[1L]] data$tempfile <- tempfile('Multipart') if (!is.null(content_type)) data$content_type <- content_type data$head <- head con <- file(data$tempfile,open='wb') writeBin(value,con) close(con) params[[name]] <- data } else { len <- length(value) # Trim trailing EOL if (len > 2 && length(Utils$raw.match(EOL,value[(len-1):len],all=FALSE))) len <- len -2 # handle array parameters paramValue <- Utils$escape(rawToChar(value[1:len])) paramSet <- FALSE if (grepl("\\[\\]$", name)) { name <- sub("\\[\\]$", "", name) if (name %in% names(params)) { params[[name]] <- c(params[[name]], paramValue) paramSet <- TRUE } } if (!paramSet) { params[[name]] <- paramValue } } } break } else if (buf$unread){ fill_buffer(buf) } else { break # we've read everything and still haven't seen a valid value } } if (is.null(value)){ # bad post payload input$rewind() warning("Bad post payload: searching for a body part") return(NULL) } # Now search for ending markers or the beginning of another part while (buf$read_buffer_len < 2 && buf$unread) fill_buffer(buf) if (buf$read_buffer_len < 2 && buf$unread == 0){ # Bad stuff at the end. just return what we've got # and presume everything is okay. input$rewind() return(params) } # Valid ending if (length(Utils$raw.match('--',buf$read_buffer[1:2],all=FALSE))){ input$rewind() return(params) } # Skip past the EOL. if (length(Utils$raw.match(EOL,buf$read_buffer[1:EOL_size],all=FALSE))){ slice_buffer(1,EOL_size,buf) } else { warning("Bad post body: EOL not present") input$rewind() return(params) } # another sanity check before we try to parse another part if ((buf$read_buffer_len + buf$unread) < boundary_size){ warning("Bad post body: unknown trailing bytes") input$rewind() return(params) } } }, build = function(params){ } ) )$new() Mime <- setRefClass( 'Mime', fields = 'MIME_TYPES', methods = list( initialize = function(...){ MIME_TYPES <<- new.env(hash=TRUE) with(MIME_TYPES,{ ".3gp" <- "video/3gpp" ".a" <- "application/octet-stream" ".ai" <- "application/postscript" ".aif" <- "audio/x-aiff" ".aiff" <- "audio/x-aiff" ".asc" <- "application/pgp-signature" ".asf" <- "video/x-ms-asf" ".asm" <- "text/x-asm" ".asx" <- "video/x-ms-asf" ".atom" <- "application/atom+xml" ".au" <- "audio/basic" ".avi" <- "video/x-msvideo" ".bat" <- "application/x-msdownload" ".bin" <- "application/octet-stream" ".bmp" <- "image/bmp" ".bz2" <- "application/x-bzip2" ".c" <- "text/x-c" ".cab" <- "application/vnd.ms-cab-compressed" ".cc" <- "text/x-c" ".chm" <- "application/vnd.ms-htmlhelp" ".class" <- "application/octet-stream" ".com" <- "application/x-msdownload" ".conf" <- "text/plain" ".cpp" <- "text/x-c" ".crt" <- "application/x-x509-ca-cert" ".css" <- "text/css" ".csv" <- "text/csv" ".cxx" <- "text/x-c" ".deb" <- "application/x-debian-package" ".der" <- "application/x-x509-ca-cert" ".diff" <- "text/x-diff" ".djv" <- "image/vnd.djvu" ".djvu" <- "image/vnd.djvu" ".dll" <- "application/x-msdownload" ".dmg" <- "application/octet-stream" ".doc" <- "application/msword" ".dot" <- "application/msword" ".dtd" <- "application/xml-dtd" ".dvi" <- "application/x-dvi" ".ear" <- "application/java-archive" ".eml" <- "message/rfc822" ".eps" <- "application/postscript" ".exe" <- "application/x-msdownload" ".f" <- "text/x-fortran" ".f77" <- "text/x-fortran" ".f90" <- "text/x-fortran" ".flv" <- "video/x-flv" ".for" <- "text/x-fortran" ".gem" <- "application/octet-stream" ".gemspec" <- "text/x-script.ruby" ".gif" <- "image/gif" ".gz" <- "application/x-gzip" ".h" <- "text/x-c" ".htc" <- "text/x-component" ".hh" <- "text/x-c" ".htm" <- "text/html" ".html" <- "text/html" ".ico" <- "image/vnd.microsoft.icon" ".ics" <- "text/calendar" ".ifb" <- "text/calendar" ".iso" <- "application/octet-stream" ".jar" <- "application/java-archive" ".java" <- "text/x-java-source" ".jnlp" <- "application/x-java-jnlp-file" ".jpeg" <- "image/jpeg" ".jpg" <- "image/jpeg" ".js" <- "application/javascript" ".json" <- "application/json" ".log" <- "text/plain" ".m3u" <- "audio/x-mpegurl" ".m4v" <- "video/mp4" ".man" <- "text/troff" ".manifest"<- "text/cache-manifest" ".mathml" <- "application/mathml+xml" ".mbox" <- "application/mbox" ".mdoc" <- "text/troff" ".me" <- "text/troff" ".mid" <- "audio/midi" ".midi" <- "audio/midi" ".mime" <- "message/rfc822" ".mml" <- "application/mathml+xml" ".mng" <- "video/x-mng" ".mov" <- "video/quicktime" ".mp3" <- "audio/mpeg" ".mp4" <- "video/mp4" ".mp4v" <- "video/mp4" ".mpeg" <- "video/mpeg" ".mpg" <- "video/mpeg" ".ms" <- "text/troff" ".msi" <- "application/x-msdownload" ".odp" <- "application/vnd.oasis.opendocument.presentation" ".ods" <- "application/vnd.oasis.opendocument.spreadsheet" ".odt" <- "application/vnd.oasis.opendocument.text" ".ogg" <- "application/ogg" ".ogv" <- "video/ogg" ".p" <- "text/x-pascal" ".pas" <- "text/x-pascal" ".pbm" <- "image/x-portable-bitmap" ".pdf" <- "application/pdf" ".pem" <- "application/x-x509-ca-cert" ".pgm" <- "image/x-portable-graymap" ".pgp" <- "application/pgp-encrypted" ".pkg" <- "application/octet-stream" ".pl" <- "text/x-script.perl" ".pm" <- "text/x-script.perl-module" ".png" <- "image/png" ".pnm" <- "image/x-portable-anymap" ".ppm" <- "image/x-portable-pixmap" ".pps" <- "application/vnd.ms-powerpoint" ".ppt" <- "application/vnd.ms-powerpoint" ".ps" <- "application/postscript" ".psd" <- "image/vnd.adobe.photoshop" ".py" <- "text/x-script.python" ".qt" <- "video/quicktime" ".ra" <- "audio/x-pn-realaudio" ".rake" <- "text/x-script.ruby" ".ram" <- "audio/x-pn-realaudio" ".rar" <- "application/x-rar-compressed" ".rb" <- "text/x-script.ruby" ".rdf" <- "application/rdf+xml" ".roff" <- "text/troff" ".rpm" <- "application/x-redhat-package-manager" ".rss" <- "application/rss+xml" ".rtf" <- "application/rtf" ".ru" <- "text/x-script.ruby" ".s" <- "text/x-asm" ".sgm" <- "text/sgml" ".sgml" <- "text/sgml" ".sh" <- "application/x-sh" ".sig" <- "application/pgp-signature" ".snd" <- "audio/basic" ".so" <- "application/octet-stream" ".svg" <- "image/svg+xml" ".svgz" <- "image/svg+xml" ".swf" <- "application/x-shockwave-flash" ".t" <- "text/troff" ".tar" <- "application/x-tar" ".tbz" <- "application/x-bzip-compressed-tar" ".tcl" <- "application/x-tcl" ".tex" <- "application/x-tex" ".texi" <- "application/x-texinfo" ".texinfo" <- "application/x-texinfo" ".text" <- "text/plain" ".tif" <- "image/tiff" ".tiff" <- "image/tiff" ".torrent" <- "application/x-bittorrent" ".tr" <- "text/troff" ".txt" <- "text/plain" ".vcf" <- "text/x-vcard" ".vcs" <- "text/x-vcalendar" ".vrml" <- "model/vrml" ".war" <- "application/java-archive" ".wav" <- "audio/x-wav" ".webm" <- "video/webm" ".wma" <- "audio/x-ms-wma" ".wmv" <- "video/x-ms-wmv" ".wmx" <- "video/x-ms-wmx" ".wrl" <- "model/vrml" ".wsdl" <- "application/wsdl+xml" ".xbm" <- "image/x-xbitmap" ".xhtml" <- "application/xhtml+xml" ".xls" <- "application/vnd.ms-excel" ".xml" <- "application/xml" ".xpm" <- "image/x-xpixmap" ".xsl" <- "application/xml" ".xslt" <- "application/xslt+xml" ".yaml" <- "text/yaml" ".yml" <- "text/yaml" ".zip" <- "application/zip" }) callSuper(...) }, file_extname = function(fname=NULL){ if (is.null(fname)) base::stop("need an argument of character") paste('.',rev(strsplit(fname,'.',fixed=TRUE)[[1]])[1],sep='') }, mime_type=function(ext=NULL,fallback='application/octet-stream'){ if (is.null(ext) || !nzchar(ext) || is.null(MIME_TYPES[[ext]])) fallback else MIME_TYPES[[ext]] } ) )$new() Rook/R/suspend.R0000644000175100001440000000050012332170455013204 0ustar hornikuserssuspend_console <- function(){ # My first approach to suspending the console # was to call Sys.sleep with .Machine$integer.max, however # this fails on windows because its implementating causes # overflow. # So we sleep for a day, and then loop. allday <- 24*60*60 while(TRUE) Sys.sleep(allday) } Rook/R/Request.R0000644000175100001440000001272212332170455013164 0ustar hornikusersRequest <- setRefClass( 'Request', fields = c('FORM_DATA_MEDIA_TYPES','PARSEABLE_DATA_MEDIA_TYPES','env'), methods = list( initialize = function(env,...){ env <<- env # The set of form-data media-types. Requests that do not indicate # one of the media types presents in this list will not be eligible # for form-data / param parsing. FORM_DATA_MEDIA_TYPES <<- c( 'application/x-www-form-urlencoded', 'multipart/form-data' ) # The set of media-types. Requests that do not indicate # one of the media types presents in this list will not be eligible # for param parsing like soap attachments or generic multiparts. PARSEABLE_DATA_MEDIA_TYPES <<- c( 'multipart/related', 'multipart/mixed' ) # Adjust script name if we're sitting behind a reverse proxy # # Nginx example config: # # location /rhttpd { # rewrite ^/rhttpd(.*)$ $1 break; # proxy_pass http://127.0.0.1:12344; # proxy_set_header X-Script-Name /rhttpd; # } # if (exists('HTTP_X_SCRIPT_NAME',env)){ env[['HTTP_X_SCRIPT_NAME']] <<- sub('/$','',env[['HTTP_X_SCRIPT_NAME']]) env[['SCRIPT_NAME']] <<- paste(env[['HTTP_X_SCRIPT_NAME']],env[['SCRIPT_NAME']],sep='') } callSuper(...) }, body = function() env[["rook.input"]], scheme = function() env[["rook.url_scheme"]], path_info = function() env[["PATH_INFO"]], port = function() as.integer(env[["SERVER_PORT"]]), request_method = function() env[["REQUEST_METHOD"]], query_string = function() env[["QUERY_STRING"]], content_length = function() env[['CONTENT_LENGTH']], content_type = function() env[['CONTENT_TYPE']], media_type = function(){ if (is.null(content_type())) return(NULL) tolower(strsplit(content_type(),'\\s*[;,]\\s*')[[1]][1]) }, media_type_params = function(){ if (is.null(content_type())) return(NULL) params <- list() for(i in strsplit(content_type(),'\\s*[;,]\\s*')[[1]][-1]){ x <- strsplit(i,'=')[[1]] params[[tolower(x[1])]] <- x[2] } params }, content_charset = function() media_type_params()[['charset']], host_with_port = function(){ if(exists('HTTP_X_FORWARDED_HOST',env)){ x <- strsplit(env[['HTTP_X_FORWARDED_HOST']],',\\s?')[[1]] return(x[length(x)]) } else if (exists('HTTP_HOST',env)){ env[['HTTP_HOST']] } else { if (exists('SERVER_NAME',env)) host <- env[['SERVER_NAME']] else host <- env[['SERVER_ADDR']] paste(host,env[['SERVER_PORT']],sep=':') } }, host = function() sub(':\\d+','',host_with_port(),perl=TRUE), script_name = function(s=NULL){ if (!is.null(s) && is.character(s)) env[['SCRIPT_NAME']] <<- s env[['SCRIPT_NAME']] }, path_info = function(s=NULL){ if (!is.null(s) && is.character(s)) env[['PATH_INFO']] <<- s env[['PATH_INFO']] }, delete = function() request_method() == 'DELETE', get = function() request_method() == 'GET', head = function() request_method() == 'HEAD', options = function() request_method() == 'OPTIONS', post = function() request_method() == 'POST', put = function() request_method() == 'PUT', trace = function() request_method() == 'TRACE', form_data = function(){ (post() && !is.null(media_type())) || any(FORM_DATA_MEDIA_TYPES==media_type()) }, parseable_data = function(){ any(PARSEABLE_DATA_MEDIA_TYPES==media_type()) }, GET = function(){ if (!exists('rook.request.query_list',env)) env[['rook.request.query_list']] <<- Utils$parse_query(query_string()) env[['rook.request.query_list']] }, POST = function(){ if (!exists('rook.input',env)) stop("Missing rook.input") if (exists('rook.request.form_list',env)) env[['rook.request.form_list']] else if (form_data() || parseable_data()){ env[['rook.request.form_list']] <<- Multipart$parse(env) if (length(env[['rook.request.form_list']]) == 0){ form_vars <- env[['rook.input']]$read() env[['rook.request.form_list']] <<- Utils$parse_query(rawToChar(form_vars)) } } env[['rook.request.form_list']] }, params = function() c(GET(),POST()) , referer = function(){ if (!is.null(env[['HTTP_REFERER']])) env[['HTTP_REFERER']] else '/' }, referrer = function() referer(), user_agent = function() env[['HTTP_USER_AGENT']], cookies = function(){ if (exists('rook.request.cookie_list',env)) return(env[['rook.request.cookie_list']]) if (!is.null(env[['HTTP_COOKIE']])) env[['rook.request.cookie_list']] <<- Utils$parse_query(env[['HTTP_COOKIE']]) else env[['rook.request.cookie_list']] <<- NULL }, xhr = function() { (exists('HTTP_X_REQUESTED_WITH',env) && env[['HTTP_X_REQUESTED_WITH']] == 'XMLHttpRequest') }, url = function(){ x <- paste(scheme(),'://',host(),sep='') if ( (scheme() == 'https' && port() != 443) || (scheme() == 'http' && port() != 80)) x <- paste(x,':',port(),sep='') x <- paste(x,fullpath(),sep='') x }, path = function() paste(script_name(),path_info(),sep=''), fullpath = function(){ if (is.null(query_string())) path() else paste(path(),'?',query_string(),sep='') }, to_url = function(url,...) { newurl <- paste(script_name(),url,sep='') opt <- list(...) if (length(opt)){ newurl <- paste( newurl,'?', paste(names(opt),opt,sep='=',collapse='&'), sep='' ) } newurl }, accept_encoding = function() env[['HTTP_ACCEPT_ENCODING']], ip = function() env[['REMOTE_ADDR']] ) ) Rook/R/onLoad.R0000644000175100001440000000055512332170455012751 0ustar hornikusers# Server object available to web servers to set how they please. # Must be set in onLoad. After that, they are locked. Server <- NULL .onLoad <- function(libpath, pkgname){ if ('(embedding)' %in% names(getLoadedDLLs()) && 'rapache' %in% search()){ sys.source( file.path(libpath,pkgname,'servers','rApache.R'), envir = asNamespace('Rook') ) } } Rook/R/Response.R0000644000175100001440000000275212332170455013334 0ustar hornikusersResponse <- setRefClass( 'Response', fields = c('body','status','headers','length'), methods = list( initialize = function(body='',status=200,headers=list(),...){ .self$status <- as.integer(status) .self$headers <- as.environment(list('Content-Type'='text/html')) if (length(headers) > 0) .self$headers <- as.environment(c(as.list(.self$headers),headers)) if (!is.character(body) && !is.raw(body)){ base::stop('Body must be a character or raw vector, not',typeof(body)) } .self$body <- body .self$length <- Utils$bytesize(.self$body) callSuper(...) }, header = function(key,value) { if (missing(value)) headers[[key]] else headers[[key]] <<- value }, set_cookie = function(key,value){ Utils$set_cookie_header(headers,key,value) }, delete_cookie = function(key,value){ Utils$delete_cookie_header(headers, key, value) }, redirect = function(target,status=302){ status <<- as.integer(status) header('Location',target) }, finish = function(){ list( status=status, headers = as.list(headers), body = body ) }, write = function(str){ s <- paste(as.character(str),collapse='') length <<- length + Utils$bytesize(s) header('Content-Length',length) body <<- paste(body,s,sep='') } ) ) Rook/R/Redirect.R0000644000175100001440000000047212332170455013274 0ustar hornikusersRedirect <- setRefClass( 'Redirect', fields = c('url'), methods = list( initialize = function(url,...){ url <<- url callSuper(...) }, call = function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() res$redirect(req$to_url(url)) res$finish() } ) ) Rook/R/URLMap.R0000644000175100001440000000156712332170455012641 0ustar hornikusersURLMap <- setRefClass( 'URLMap', fields = c('map'), methods = list( initialize = function(...){ apps <- list(...) map <<- list() for (url in names(apps)){ x <- apps[[url]] if (is(x,'function')) map[[length(map)+1]] <<- App$new(x) else if (is_rookable(x)) map[[length(map)+1]] <<- x else stop("App for url ",url," not rookable") } names(map) <<- names(apps) callSuper() }, call = function(env){ path <- env[['PATH_INFO']] for (url in names(map)){ #cat('matching url',url,'to',path,'\n') if (grepl(url,path)) return(map[[url]]$call(env)) } body <- paste("File not found:",path,"\n") list( status=404L, headers = list( "Content-Type" = "text/plain", "Content-Length" = as.character(nchar(body)), "X-Cascade" = "pass" ), body = body ) } ) ) Rook/R/Builder.R0000644000175100001440000000060312332170455013115 0ustar hornikusersBuilder <- setRefClass( 'Builder', contains = 'App', methods = list( initialize = function(...){ objs <- list(...) if (length(objs) > 1){ for (i in 1:(length(objs)-1)){ if (inherits(objs[[i]],'Middleware')) objs[[i]]$set_app(objs[[i+1]]) else stop("Argument ",i,"is not a Middleware object") } } callSuper(app=objs[[1]]) } ) ) Rook/R/File.R0000644000175100001440000000434312421230533012404 0ustar hornikusersFile <- setRefClass( 'File', fields = c('root','path_info','path'), methods = list( initialize = function(root,...){ root <<- root callSuper(...) }, call = function(env){ path_info <<- Utils$unescape(env[["PATH_INFO"]]) if (length(grep('..',path_info,fixed=TRUE))){ return(forbidden()) } if (grepl('#',path_info)) path_info <<- strsplit(path_info,'#')[[1]] if (grepl('\\?',path_info)) path_info <<- strsplit(path_info,'\\?',)[[1]] path <<- normalizePath(file.path(root,path_info)) if (file_test('-d',path)){ if(!grepl(".*/$", path_info)){ return(redirect(paste(env[["SCRIPT_NAME"]], env[["PATH_INFO"]], "/", sep=""), status=301)) } newpath <- file.path(path, "index.html") if(file.exists(newpath)){ path <<- normalizePath(newpath) serving() } else { return(indexdir()) } } else if (file.exists(path)){ serving() } else { not_found() } }, forbidden = function(){ body = 'Forbidden\n' list( status=403L, headers = list( 'Content-type' = 'text/plain', 'Content-Length' = as.character(nchar(body)), 'X-Cascade' = 'pass' ), body = body ) }, indexdir = function(){ body <- paste(list.files(path), collapse="\n") list( status=200L, headers = list( 'Content-type' = 'text/plain', 'Content-Length' = as.character(nchar(body)) ), body = body ) }, redirect = function(location){ res <- Response$new() res$redirect(location, status=302) res$finish() }, serving = function(){ fi <- file.info(path) if (fi$size > 0) { body = readBin(path,'raw',fi$size) } else { body <- path names(body) <- 'file' } list ( status=200L, headers = list( 'Last-Modified' = Utils$rfc2822(fi$mtime), 'Content-Type' = Mime$mime_type(Mime$file_extname(basename(path))), 'Content-Length' = as.character(fi$size) ), body=body ) }, not_found = function(){ body <- paste("File not found:",path_info,"\n") list( status=404L, headers = list( "Content-Type" = "text/plain", "Content-Length" = as.character(nchar(body)), "X-Cascade" = "pass" ), body = body ) } ) ) Rook/R/Rookery.R0000644000175100001440000000743612332170455013174 0ustar hornikusers.RookeryApp <- setRefClass( 'RookeryApp', fields = c('app','name','appEnv','configured','workingDir'), methods = list( initialize = function(app=NULL,name=NULL,...){ if (is.null(name) || !is.character(name)){ base::warning("Need a proper app 'name'") .self$configured <- FALSE return(callSuper(...)) } .self$name <- name if (is.character(app) && file.exists(app)){ .self$workingDir <- dirname(app) oldwd <- setwd(.self$workingDir) 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::warning("Cannot find a suitable app in file ",app) .self$app <- NULL } } else { base::warning("File does not exist: ",app) .self$configured <- FALSE; } if (!is_rookable(.self$app)){ base::warning("App ",name," is not rookable'") .self$configured <- FALSE; } else { .self$configured <- TRUE; } callSuper(...) } ) ) .Rookery <- setRefClass( 'Rookery', fields = c('req','res','appHash','messages'), methods = list( initialize = function(...){ appHash <<- new.env() messages <<- list( emptypath = c( '

Oops! option Rook.Rookery.paths is NULL

', '

You must set this to a character vector containing', 'valid directories where Rook apps live.

' ), nodots = c( '

Apps cannot be named . or ..

' ) ) callSuper(...) }, message = function(name,opt=NULL){ msg <- paste(messages,collapse='\n') if (!is.null(opt)) msg <- sprintf(msg,opt) res$header('Content-Type','text/html') res$write(msg) }, findSuitableApp = function(appName){ if (appName %in% c('.','..')){ message('nodots') return(NULL) } paths <- getOption('Rook.Rookery.paths') if (is.null(paths)){ message('emptypath') return(NULL) } #for (p in paths){ # appReg <- paste('^',appName,'$',sep='') # if (any(grepl(appReg,basename(list.dirs(p,recursive=FALSE))))){ # } else if ( #} }, listAllApps = function(){ }, call = function(env){ req <<- Request$new(env) res <<- Response$new() # Captures foo from "/foo/.*". Presumes leading /. appName <- strsplit(req$path_info(),'/',fixed=TRUE)[[1]][2] if (is.na(appName)){ listAllApps() } else { app <- findSuitableApp(appName) if (!is.null(app)){ new_path_info <- req$path_info() req$path_info(sub(paste("/",appName,sep=''),'',new_path_info)) oldwd <- setwd(app$workingDir) on.exit(setwd(oldwd)) if (is(app$app,'function')) { return(app$app(env)) } else { return(app$app$call(env)) } } } #res$write("
")
         #res$write(paste(capture.output(ls.str(env)),collapse='\n'))
         #res$write("
") res$finish() } ) ) Rook/R/App.R0000644000175100001440000000131012332170455012243 0ustar hornikusersis_rookable <- function(app){ if (is(app,'refClass')) TRUE else if (is(app,'function')) TRUE else FALSE } # Abstract Rook::App and Rook::Middleware that Builder and related apps inherit from. App <- setRefClass( 'App', fields = c('app'), methods = list( initialize = function(app=NULL,...) { app <<- app callSuper(...) }, call = function(env){ if (is(app,'refClass')) app$call(env) else if (is(app,'function')) app(env) else stop('App not Rook aware') } ) ) Middleware <- setRefClass( 'Middleware', contains = 'App', methods = list( initialize = function(...) { callSuper(...) }, set_app = function(app){ app <<- app } ) ) Rook/R/Static.R0000644000175100001440000000071012332170455012755 0ustar hornikusersStatic <- setRefClass( 'Static', 'contains' = 'Middleware', fields = c('urls','file_server'), methods = list( initialize = function(urls=c(),root=pwd(),...){ urls <<- paste('^',urls,sep='') file_server <<- Rook::File$new(root) callSuper(...) }, call = function(env){ path <- env[["PATH_INFO"]] if (any(sapply(urls,function(i)length(grep(i,path))>0))) file_server$call(env) else app$call(env) } ) ) Rook/R/Rhttpd.R0000644000175100001440000003016512332170455013002 0ustar hornikusersRhttpdApp <- 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 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 } ) ) Rook/R/Brewery.R0000644000175100001440000000266412332170455013157 0ustar hornikusersBrewery <- setRefClass( 'Brewery', contains = 'Middleware', fields = c('url','root','opt'), methods = list( initialize = function(url,root,...){ library("brew") url <<- sub("/+$","",url) root <<- normalizePath(root,mustWork=TRUE) opts <- list(...) if (length(opts)>0){ opt <<- try(list2env(opts),silent=TRUE) if (inherits(opt,'try-error')) stop('Optional arguments must be named') } else { opt <<- new.env() } callSuper() }, call = function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() opt[['req']] <<- req opt[['res']] <<- res path <- env[["PATH_INFO"]] file_path <- try( normalizePath(file.path(root,path),mustWork=TRUE), silent=TRUE ) if (!inherits(file_path, 'try-error') && grepl(paste('^',url,sep=''),path) && !grepl(paste('^',url,'$',sep=''),path) && grepl(paste('^',root,url,.Platform$file.sep,sep=''),file_path)){ oldwd <- setwd(dirname(file_path)) on.exit(setwd(oldwd)) res$write( paste(capture.output(brew::brew(basename(file_path),envir=opt)), collapse="\n") ) res$finish() } else { app$call(env) } } ) ) Rook/README.md0000644000175100001440000001006312332170455012463 0ustar hornikusersRook: A web server interface for R ======================================= This pecification defines the interface between web servers and R applications. Rook applications ----------------- A Rook application is an R reference class object that implements a 'call' method or an R closure that takes exactly one argument, an environment, and returns a list with three named elements: the 'status', the 'headers', and the 'body'. Hello World ----------- Here is a basic Rook application as a closure that implements 'hello world': function(env){ body = paste('

Hello World! This is Rook',env$rook.version,'.

') list( status = 200L, headers = list( 'Content-Type' = 'text/html' ), body = body ) } And the equivalent referenc class example: setRefClass( 'HelloWorld', methods = list( call = function(env){ body = paste('

Hello World! This is Rook',env$rook.version,'.

') list( status = 200L, headers = list( 'Content-Type' = 'text/html' ), body = body ) } ) ) The Environment --------------- The environment argument is a true R environment object which the application is free to modify. It is required to contain the following variables: - REQUEST_METHOD: The HTTP request method, such as "GET" or "POST". This cannot ever be an empty string, and so is always required. - SCRIPT_NAME: The initial portion of the request URL‘s "path" that corresponds to the application object, so that the application knows its virtual "location". This may be an empty string, if the application corresponds to the "root" of the server. - PATH_INFO: The remainder of the request URL‘s "path", designating the virtual "location" of the request‘s target within the application. This may be an empty string, if the request URL targets the application root and does not have a trailing slash. This value may be percent-encoded when I originating from a URL. - QUERY_STRING: The portion of the request URL that follows the ?, if any. May be empty, but is always required! - SERVER_NAME, SERVER_PORT: When combined with SCRIPT_NAME and PATH_INFO, these variables can be used to complete the URL. Note, however, that HTTP_HOST, if present, should be used in preference to SERVER_NAME for reconstructing the request URL. SERVER_NAME and SERVER_PORT can never be empty strings, and so are always required. - HTTP_ Variables: Variables corresponding to the client-supplied HTTP request headers (i.e., variables whose names begin with HTTP_). The presence or absence of these variables should correspond with the presence or absence of the appropriate HTTP header in the request. In addtion, the environment must include the following Rook-specific variables: - rook.version: This version of Rook. - rook.url_scheme: http or https, depending on the request URL. - rook.input: See below, the input stream. - rook.errors: See below, the error stream. The Input Stream ---------------- The rook.input variable must contain an object created from a reference class and respond to read_lines, read, and rewind: read_lines: takes one argument, the number of lines to read. Includes partial ending line. read: takes one argument, the number of bytes to read. Returns a raw vector. rewind: Rewinds the input stream back to the beginning. The Error Stream ---------------- The rook.error variable must contain an object created from a reference class and must respond to flush and cat: flush: called with no arguments and makes the error stream immediately appear. cat: called with the same arguments as R's cat without the file and append argument. The Response ============ The Status ---------- This is an HTTP status value and must be greater than or equal to 100. The Headers ----------- This is a named list that contains string values only corresponding to valid HTTP headers. The Body -------- This is either a character or raw vector. If the character vector is named with value 'file' then value of the vector is interpreted as the location of a file. Rook/MD50000644000175100001440000000646712421241716011527 0ustar hornikuserse9f9cd52111e483a1b8a87dac26b7281 *DESCRIPTION 650bfb45832c5d8a86559d66f998112e *NAMESPACE 02f4925e8efe6b71995eb70fc92ef838 *R/App.R 28ff39414be47e7eb14a0f7aa720a996 *R/Brewery.R 349afa5b85e1d4858aa031f04d724c75 *R/Builder.R 1e247fbe138e57a6a0cf6a53c6ac22ba *R/File.R 9a65be637551eee4d6b6cd1e30d7dd51 *R/Redirect.R 028b53ef7c03c0fa29f0d6cfa8646a09 *R/Request.R 7fc06954aa3751fc2233097605d36da2 *R/Response.R 9b01f908a701566beedc2bc76bf64f38 *R/Rhttpd.R 388278765c045d966a5954a7a3e083fe *R/Rookery.R e6952d21f4eb6d2825192f527fa91d44 *R/Static.R 4c6f94bf4d06905a12222e092509cd9e *R/URLMap.R f96de9e408627b7bae010551bfe82c05 *R/onLoad.R ca1ab77a4d132f473597c2f0654a6863 *R/suspend.R 3386f56092b10d4819aa92fdcf58ca13 *R/utils.R 480b84a0dcfbbaed0b8981deec5a798f *README.md adf370611ed7a3759aab58762ee21b70 *inst/exampleApps/Hmisc/brew/useR2007.rhtml 2d7419abc0eb05710ac955d5937e62b9 *inst/exampleApps/Hmisc/brew/useR2007plot.rhtml 564c64d585bd6f6fe94e89c7c6da1cdf *inst/exampleApps/Hmisc/brew/useR2007sim.rhtml 37203b0760f00592e2a281809b0a20de *inst/exampleApps/Hmisc/config.R 4f8207a890445d3b5af7bab91566ef9f *inst/exampleApps/Hmisc/css/useR2007.css c7b3cbb3ec8249a7121b722cdd76b870 *inst/exampleApps/Hmisc/images/spinner.gif 3766aeff5778b54f74f93670322ca0df *inst/exampleApps/Hmisc/javascript/prototype.js dd9bf8533e52019ce44baf753709375d *inst/exampleApps/Hmisc/javascript/useR2007.js 37a3db9f6084f7914ca44d20e72ebd61 *inst/exampleApps/RJSONIO.R 1f3e91e0d29904283205b2859c4455aa *inst/exampleApps/RookTestApp.R 79653e32a45a37e3ce8b1cbed26f5cc5 *inst/exampleApps/arrayparams.R 6f34aace2db5531ac3692ee84a544d80 *inst/exampleApps/exampleData/config.R 74e4c2ff34d39d0b6380f954407c4dd9 *inst/exampleApps/exampleData/dataset.html ad89a9918e9180bf1eb609f1a7a38208 *inst/exampleApps/exampleData/error.html b3d4ef882905dcc309af443d4a68ac74 *inst/exampleApps/exampleData/index.html cbd04008d124ae73b244f0748a17f8db *inst/exampleApps/helloworld.R 235eeab8a0d1841605632ffaa1f11afd *inst/exampleApps/helloworldref.R 8836fd77254deb077638221d1f961504 *inst/exampleApps/rnorm.R 8e4c29f13a0bb2ecd93902200a7bd3ac *inst/exampleApps/summary.R b8e9bfe22a3bef27a59f9ee4922f2812 *inst/servers/rApache.R 4d18d0b1a9867625b55ba6366d5307f8 *man/App-class.Rd 55ac7aee30e7689ee342c457f0d8fdbf *man/Brewery-class.Rd 7a5a9668f77c7c37526b89d4f84fde2d *man/Builder-class.Rd 23565fc4d319605f6c61b4b63a46f585 *man/File-class.Rd 20d9660f278978e49614c9f8350ce08c *man/Middleware-class.Rd 18d171cb0386ea6ef0250869a4eb21e1 *man/Mime-class.Rd c78f79f7d08964e296acb203c06f1a4b *man/Multipart-class.Rd e34725a707852d69f13b284111caa134 *man/Redirect-class.Rd edf6b984840515918404d6e0acc5bff1 *man/Request-class.Rd afbdb8da06d7435799c31a51662aeddc *man/Response-class.Rd e48a4890dcbbc101daa184ddea263fbd *man/Rhttpd-class.Rd 4b0a5321ef95caa5c8ee322e05489929 *man/RhttpdApp-class.Rd b4ca5628c946c5fb5bbb562fdf2c8fbc *man/RhttpdErrorStream-class.Rd 9a005f85b34a3ed81e9f8052cbb85f5f *man/RhttpdInputStream-class.Rd 88c81e7020ea705be2e8def1137cb636 *man/Rook-package.Rd 7cf4a6c046827a368011f0bf0e941e40 *man/Server.Rd d1df0d5241859943648746094a829bd2 *man/Static-class.Rd 9ad6afcaa735ae237a4fff8046208808 *man/URLMap-class.Rd ed543f4c501e0a118cd0b1444013378c *man/Utils-class.Rd 3a1e51a545be75c909c32534cd279208 *man/is_rookable.Rd 3204397bf12765f04e930e3755216714 *man/suspend_console.Rd b89621c0102d6c2ab1f0ee2fed59b930 *src/rook.c Rook/DESCRIPTION0000644000175100001440000000113612421241716012711 0ustar hornikusersPackage: Rook Type: Package Title: Rook - a web server interface for R Version: 1.1-1 Date: 2014-10-20 Author: Jeffrey Horner Maintainer: Jeffrey Horner Description: This package contains the Rook specification and convenience software for building and running Rook applications. To get started, be sure and read the 'Rook' help file first. Depends: R (>= 2.13.0) Imports: utils, tools, methods, brew License: GPL-2 LazyLoad: yes Packaged: 2014-10-20 16:54:31 UTC; jeffrey NeedsCompilation: yes Repository: CRAN Date/Publication: 2014-10-20 19:18:06 Rook/man/0000755000175100001440000000000012421227305011753 5ustar hornikusersRook/man/App-class.Rd0000644000175100001440000000131212332170455014066 0ustar hornikusers\name{App-class} \Rdversion{1.1} \docType{class} \alias{App-class} \alias{App} \title{Class \code{App}} \description{ Abstract class from which \code{Middleware} and \code{Builder} inherit. Provides the \code{app} field. \code{App} can also be used to instantiate reference classed applications wrapped around a function. See \code{\link{Middleware}} for an example. } \section{Fields}{ \describe{ \item{\code{app}:}{A Rook application.} } } \section{Methods}{ \describe{ \item{\code{new(app=NULL)}:}{ Creates a new \code{App} object. \code{app} is any \code{Rook} aware R object.} } } \seealso{ \code{\link{is_rookable}}, \code{\link{Builder}}, and \code{\link{Middleware}}. } \keyword{classes} Rook/man/Response-class.Rd0000644000175100001440000000317412421227305015150 0ustar hornikusers\name{Response-class} \Rdversion{1.1} \docType{class} \alias{Response-class} \alias{Response} \title{Class \code{Response}} \description{ A convenience class for creating \code{\link{Rook}} responses. } \seealso{ \code{\link{Rhttpd}} and \code{\link{Request}}. } \examples{ s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) } s$add(name="response", app=function(env){ req <- Request$new(env) res <- Response$new() res$write('hello') res$finish() } ) \dontrun{ s$browse('response') # Opens a browser window to the app. } s$remove(all=TRUE) rm(s) } \keyword{classes} \section{Methods}{ \describe{ \item{\code{header(key, value)}:}{ Sets an HTTP header for the response. Both \code{key} and \code{value} must be character strings. If \code{value} is missing, then the \code{header} value is returned.} \item{\code{redirect(target, status=302)}:}{ Sets up an HTTP redirect to the \code{target} url. } \item{\code{write(str)}:}{ Takes a character vector and appends it to the response body. } \item{\code{new(body='', status=200, headers=list())}:}{ Create a new Response object. \code{body} is a character vector, \code{status} is an HTTP status value. \code{headers} is a named list.} \item{\code{set_cookie(key, value)}:}{ Sets an HTTP cookie for the response. Both \code{key} and \code{value} must be character strings.} \item{\code{delete_cookie(key, value)}:}{ Sends appropriate HTTP header to delete the associated cookie on the client. \code{key} and \code{value} must be character strings.} \item{\code{finish()}:}{ Returns the response according to the Rook specification.} } } Rook/man/Static-class.Rd0000644000175100001440000000107212332170455014600 0ustar hornikusers\name{Static-class} \Rdversion{1.1} \docType{class} \alias{Static-class} \alias{Static} \title{Class \code{Static}} \description{ A \code{\link{Middleware}} class for serving static files from a root directory given a set of url paths. } \seealso{ See \code{\link{Builder}} for an example. } \keyword{classes} \section{Methods}{ \describe{ \item{\code{new(urls, root)}:}{ Creates a new object. \code{urls} is a character vector whose elements must start with a \code{'/'}. \code{root} is a length 1 character vector whose value must be a valid directory. } } } Rook/man/Request-class.Rd0000644000175100001440000001560412421227305015003 0ustar hornikusers\name{Request-class} \Rdversion{1.1} \docType{class} \alias{Request-class} \alias{Request} \title{Class \code{Request}} \description{ A convenience class for working with a \code{\link{Rook}} environment. Be sure to see the example at the end of this help file. } \examples{ # # The following example prints out the result of each method. # ls_str <- function(s) paste(capture.output(str(s),file=NULL),collapse='\n') s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) } s$add(name="request", app=function(env){ req <- Request$new(env) res <- Response$new() res$set_cookie('imacookie','42') action <- req$to_url('/foo',bar=1,baz='three') res$write('
') res$write('Upload a file: ') res$write('

')
        res$write(c('parseable_data: ',req$parseable_data(),'\n'))
        res$write(c('url: ',req$url(),'\n'))
        res$write(c('request_method: ',req$request_method(),'\n'))
        res$write(c('GET: ',ls_str(req$GET()),'\n'))
        res$write(c('post: ',req$post(),'\n'))
        res$write(c('media_type: ',req$media_type(),'\n'))
        res$write(c('query_string: ',req$query_string(),'\n'))
        res$write(c('fullpath: ',req$fullpath(),'\n'))
        res$write(c('referer: ',req$referer(),'\n'))
        res$write(c('cookies: ',ls_str(req$cookies()),'\n'))
        res$write(c('content_charset: ',req$content_charset(),'\n'))
        res$write(c('head: ',req$head(),'\n'))
        res$write(c('accept_encoding: ',req$accept_encoding(),'\n'))
        res$write(c('content_length: ',req$content_length(),'\n'))
        res$write(c('form_data: ',req$form_data(),'\n'))
        res$write(c('xhr: ',req$xhr(),'\n'))
        res$write(c('params: ',ls_str(req$params()),'\n'))
        res$write(c('media_type_params:\n',ls_str(req$media_type_params()),'\n'))
        res$write(c('user_agent: ',req$user_agent(),'\n'))
        res$write(c('put: ',req$put(),'\n'))
        res$write(c('get: ',req$get(),'\n'))
        res$write(c('path: ',req$path(),'\n'))
        res$write(c('body: ',ls_str(req$body()),'\n'))
        res$write(c('port: ',req$port(),'\n'))
        res$write(c('host_with_port: ',req$host_with_port(),'\n'))
        res$write(c('scheme: ',req$scheme(),'\n'))
        res$write(c('ip: ',req$ip(),'\n'))
        res$write(c('options: ',req$options(),'\n'))
        res$write(c('to_url: ',req$to_url('foo',bar=1,baz='two'),'\n'))
        res$write(c('host: ',req$host(),'\n'))
        res$write(c('POST: ',ls_str(req$POST()),'\n'))
        res$write(c('trace: ',req$trace(),'\n'))
        res$write(c('script_name: ',req$script_name(),'\n'))
        res$write(c('content_type: ',req$content_type(),'\n'))
        res$write(c('delete: ',req$delete(),'\n'))
        res$write(c('path_info: ',req$path_info(),'\n'))
        res$write(c('\nRac env: ',ls_str(as.list(env)),'\n'))
        res$finish()
    }
)
\dontrun{
s$browse('request') # Opens a browser window to the app.
}
s$remove(all=TRUE)
rm(s)
}
\section{Methods}{
  \describe{
    \item{\code{parseable_data()}:}{ Returns a boolean value determining if the POST payload is parseable. }
    \item{\code{url()}:}{ Returns url as a character string containing the scheme, host, port, and possibly the GET query string if supplied.}
    \item{\code{request_method()}:}{ Returns the HTTP method as a character string, e.g. 'GET', 'POST', etc. }
    \item{\code{GET()}:}{ Returns a named list containing the variables parsed from the query string. }
    \item{\code{post()}:}{ Returns TRUE if the current request method is 'POST', FALSE otherwise. }
    \item{\code{new(env)}:}{ Instantiates a new \code{Request} object for the given \code{Rook} environment.}
    \item{\code{media_type()}:}{ Returns the media type for the current request as a character string.}
    \item{\code{query_string()}:}{ Returns the unparsed query string. }
    \item{\code{fullpath()}:}{ Returns the same string as url() but without the scheme, host, and port. }
    \item{\code{referer()} or \code{referrer()}:}{ Returns the referring url.  }
    \item{\code{cookies()}:}{ Returns any cookies in the request as a named list. }
    \item{\code{content_charset()}:}{ Returns the content charset as a character string. }
    \item{\code{head()}:}{ Returns TRUE if the HTTP method is 'HEAD', FALSE otherwise.}
    \item{\code{accept_encoding()}:}{ Returns the accept encoding header as a character string.}
    \item{\code{content_length()}:}{ Returns content length header value as a string. }
    \item{\code{form_data()}:}{ Returns TRUE if there's form data, e.g. POST data with the request, FALSE otherwise.}
    \item{\code{xhr()}:}{ Returns the x-requested-with header value as a character string.}
    \item{\code{params()}:}{ Returns the combination of \code{POST()} and \code{GET()} in one named list.}
    \item{\code{media_type_params()}:}{ Returns any media type parameters from the content type as a named list. }
    \item{\code{user_agent()}:}{ Returns the user-agent header value as a character string. }
    \item{\code{put()}:}{ Returns TRUE if the current request is a 'PUT'. }
    \item{\code{get()}:}{ Returns TRUE if the current request is a 'GET'. }
    \item{\code{path()}:}{ Returns a character string like \code{fullpath()} but without the query string. }
    \item{\code{body()}:}{ Returns the 'rook.input' object from the environment. See \code{\link{RhttpdInputStream}} for more information.}
    \item{\code{port()}:}{ Returns the server port as an integer.e}
    \item{\code{host_with_port()}:}{ Returns the host and port as a character string separated by ':'. }
    \item{\code{scheme()}:}{ Returns the scheme, e.g. 'http' or 'https', as a character string. }
    \item{\code{ip()}:}{ Returns the remote IP address as a character string. }
    \item{\code{options()}:}{ Returns TRUE if the current request is 'OPTIONS'. }
    \item{\code{to_url(url, ...)}:}{ Concatenates the script name with the \code{url} argument along with any named parameters passed via \code{...} .}
    \item{\code{host()}:}{ Returns the server host as a character string. }
    \item{\code{POST()}:}{ Returns a named list containing the variables parsed from the POST payload.}
    \item{\code{trace()}:}{ Returns TRUE if the current request is 'TRACE'. }
    \item{\code{script_name(s=NULL)}:}{ Returns the script name of the application, e.g. '/custom/multi'. Also, if \code{s} is not NULL, sets the script name to \code{s}. }
    \item{\code{content_type()}:}{ Returns the content-type header value as a character string. }
    \item{\code{delete()}:}{ Returns TRUE if the current request is 'DELETE'. }
    \item{\code{path_info(s=NULL)}:}{ Returns the portion of the url after the script name as a character string. If \code{s} is not NULL, sets the path info to \code{s}.}
  }
}
\seealso{
\code{\link{Rhttpd}} and \code{\link{Response}}.
}
\keyword{classes}
Rook/man/Multipart-class.Rd0000644000175100001440000000234512332170455015336 0ustar  hornikusers\name{Multipart-class}
\Rdversion{1.1}
\docType{class}
\alias{Multipart-class}
\alias{Multipart}

\title{Class \code{Multipart} and object \code{Multipart}}
\description{
A convenience object for parsing multipart/form-data POST payloads.
}
\examples{
s <- Rhttpd$new()
\dontrun{
s$start(quiet=TRUE)
}
s$add(name="multi",
    app=function(env){
        req <- Request$new(env)
        res <- Response$new()
        res$write('
') res$write('Upload a file: ') res$write('

') post <- Multipart$parse(env) if (length(post)){ poststr <- paste(capture.output(str(post),file=NULL),collapse='\n') res$write(c('
',poststr,'
')) } res$finish() } ) \dontrun{ s$browse('multi') # Opens a browser window to the app. } s$remove(all=TRUE) rm(s) } \seealso{ \code{\link{Rhttpd}}, \code{\link{Request}}, and \code{\link{Response}}. } \section{Methods}{ \describe{ \item{\code{parse(env)}:}{ Returns parsed POST payload as a named list. \code{env} is an environment created by \code{Rhttpd} and conforms to the \code{\link{Rook}} specification.} } } \keyword{classes} Rook/man/Server.Rd0000644000175100001440000000050512332170455013514 0ustar hornikusers\name{Server} \Rdversion{1.1} \alias{Server} \title{Rook Server Object} \description{ \code{Server} is an object exported by Rook that has no value to the user. It is mainly used by web servers for their convenience. To see an example of how it may be used, see rApache.R in the inst/servers directory. } \keyword{classes} Rook/man/Rhttpd-class.Rd0000644000175100001440000001003012332170455014610 0ustar hornikusers\name{Rhttpd-class} \Rdversion{1.1} \docType{class} \alias{Rhttpd-class} \alias{Rhttpd} \title{Class \code{Rhttpd}} \description{ \code{Rhttpd} is a convenience class for installing and running Rook applications. It hides the details of starting and stopping the server and adding and removing \code{Rook} applications from the server. Users starts by creating one \code{Rhttpd} object, then adding applications to it, and then starting the server (see the section \dQuote{Examples} for a typical session). There are no restrictions on creating more than one server object, but know that it only manages the applications that are added to it and not others. Applications can be added and removed regardless of whether or not the server is running. Stopping the server does not remove any applications. Adding an application with the same name as one already installed simply overwrites the one installed. If the server is started with no applications installed, it will install the application named \code{RookTestApp} located in: \code{system.file('exampleApps/RookTestApp.R',package='Rook')}. Also, see \code{\link{browseURL}} to learn how to get R to automatically launch your favorite web browser. NOTE: This version of Rook can only listen on the loopback device. } \seealso{ \code{\link{RhttpdApp}} } \examples{ # Create an Rhttpd object and start the internal web server. Note that # if there are no applications added, then the default RookTest app in # system.file('exampleApps/RookTestApp.R',package='Rook') is automatically # added. s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) s$browse(1) } s$print() # Be sure to install the Hmisc package before installing and running # this application. You will want to; it's a pretty good one. # s$add( # app=system.file('exampleApps/Hmisc/config.R',package='Rook'), # name='hmisc') s$add( app=system.file('exampleApps/helloworld.R',package='Rook'), name='hello' ) s$add( app=system.file('exampleApps/helloworldref.R',package='Rook'), name='helloref' ) s$add( app=system.file('exampleApps/summary.R',package='Rook'), name='summary' ) s$print() # Stops the server but doesn't uninstall the app \dontrun{ s$stop() } s$remove(all=TRUE) rm(s) } \keyword{classes} \section{Methods}{ \describe{ \item{\code{open(x)} or \code{browse(x)}:}{ Calls \code{\link[utils]{browseURL}} on the installed Rook application designated by \code{x}. \code{x} is either an integer or a character string. See the output of \code{print()}.} \item{\code{print()} or \code{show()}:}{ Lists the installed Rook applications.} \item{\code{remove(app,all=FALSE)}:}{ Removes the application known to the server. \code{app} can be an \code{RhttpdApp} object previously added, the name of the application as a character string, or an index as a numeric or integer value. See the output of \code{print()}.} \item{\code{full_url(i)}:}{ Returns the absolute url to the application for the given index.} \item{\code{start(listen='127.0.0.1', port=getOption('help.ports'), quiet=FALSE)}:}{ Starts the server on the loopback device and \code{port}. \code{listen} is always character string. Note that if there are no applications added to the object prior to starting, then the RookTestApp located in \code{system.file('exampleApps/RookTestApp.R',package='Rook')} is automatically added.} \item{\code{new()}:}{ Create a new \code{Rhttpd} object. } \item{\code{launch(...)}:}{ Combines the steps of starting the server, creating an \code{RhttpdApp} object, adding it to the server, and opening the app in the browser. \code{...} argument is passed to \code{RhttpdApp$new()}.} \item{\code{debug()}:}{ Returns the integer value provided by \code{getOption('Rhttpd_debug')} or 0 if the option is NULL. } \item{\code{stop()}:}{ Stops the server. } \item{\code{add(app=NULL,name=NULL)}:}{ Adds a new \code{Rook} application to the server. \code{app} can be an \code{\link{RhttpdApp}} object or any \code{Rook} application. \code{name} is a character string and is ignored if \code{app} is an \code{RhttpdApp} object.} } } Rook/man/Middleware-class.Rd0000644000175100001440000000352212332170455015430 0ustar hornikusers\name{Middleware-class} \Rdversion{1.1} \docType{class} \alias{Middleware-class} \alias{Middleware} \title{Class \code{Middleware}} \description{ An abstract class for building Rook Middleware applications. \code{Middleware} applications either handle the incoming web request or hand off the request to the Rook app defined in the field of the same name. } \examples{ # Middleware applications are typically instantiated in the argument list of # Builder$new(), but here is stand-alone example. # # Once your browser loads the app, you will see something like this in # your location bar: http://127.0.0.1:28649/custom/middle. Add '/foo' # onto the end of that and reload. setRefClass( 'FooBar', contains = 'Middleware', methods = list( initialize = function(...){ # app to defer to. callSuper(app=App$new(function(env){ res <- Response$new() res$write("

I'm the deferred app.

") res$finish() })) }, call = function(env){ req <- Request$new(env) res <- Response$new() if (length(grep('foo',req$path_info()))){ res$write("

I'm the middleware app.

") return(res$finish()) } else { app$call(env) } } ) ) s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) } s$add(name="middle",app=getRefClass('FooBar')$new()) \dontrun{ s$browse('middle') # Opens a browser window to the app. } s$remove(all=TRUE) rm(s) } \seealso{ The following classes implement Middleware: \code{\link{Brewery}} and \code{\link{Static}}. } \section{Methods}{ \describe{ \item{\code{set_app(app)}:}{ \code{app} is a \code{\link{Rook}} application that will handle the request if this Middleware app does not. } } } \keyword{classes} Rook/man/Mime-class.Rd0000644000175100001440000000123712332170455014243 0ustar hornikusers\name{Mime-class} \Rdversion{1.1} \docType{class} \alias{Mime-class} \alias{Mime} \title{Class \code{Mime} and object \code{Mime}} \description{ A convenience object for determining the MIME type of a file name. } \examples{ Mime$file_extname('foo.png') Mime$mime_type('.png') } \keyword{classes} \section{Methods}{ \describe{ \item{\code{file_extname(fname=NULL)}:}{ Returns the file extensions for the given file.} \item{\code{mime_type(ext=NULL, fallback='application/octet-stream')}:}{ Returns the MIME type given the file extension. Be sure to include the dot character in \code{ext}. If no match is found, then the fallback MIME type is returned.} } } Rook/man/URLMap-class.Rd0000644000175100001440000000244212332170455014453 0ustar hornikusers\name{URLMap-class} \Rdversion{1.1} \docType{class} \alias{URLMap-class} \alias{URLMap} \title{Class \code{URLMap}} \description{ A \code{\link{Rook}} application that maps url paths to other \code{Rook} applications. } \seealso{ \code{\link{Rhttpd}}. } \examples{ s <- Rhttpd$new() s$add( name="pingpong", app=Rook::URLMap$new( '/ping' = function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() res$write(sprintf('

Pong

',req$to_url("/pong"))) res$finish() }, '/pong' = function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() res$write(sprintf('

Ping

',req$to_url("/ping"))) res$finish() }, '/?' = function(env){ req <- Rook::Request$new(env) res <- Rook::Response$new() res$redirect(req$to_url('/pong')) res$finish() } ) ) \dontrun{ s$start(quiet=TRUE) s$browse('pingpong') } s$remove('pingpong') \dontrun{ s$stop() } rm(s) } \keyword{classes} \section{Methods}{ \describe{ \item{\code{new(...)}:}{ Creates a \code{Rook} application. All arguments must be \code{Rook} applications and named as in the example.} } } Rook/man/RhttpdApp-class.Rd0000644000175100001440000000322312332170455015257 0ustar hornikusers\name{RhttpdApp-class} \Rdversion{1.1} \docType{class} \alias{RhttpdApp-class} \alias{RhttpdApp} \title{Class \code{RhttpdApp}} \description{ Creates a Rook application ready to add to an \code{\link{Rhttpd}} server. } \details{ The internal web server allows dispatching to user-defined closures located in tools:::.httpd.handlers.env. For instance, if a handler named 'foo' is placed there, then the url path to that handler is /custom/foo. \code{RhttpdApp} along with \code{\link{Rhttpd}} hide these details by allowing a user to create application objects specifying only their name and the application. There is currently a limit of 63 characters or less for application names. NOTE: When a file is given as the value of the \code{app} argument to \code{new()}, it is monitored for timestamp changes. If a change occurs in the modification time as returned by \code{\link[base]{file.info}}, then the file is sourced prior to handling subsequent requests. } \seealso{ \code{\link{Rhttpd}}. } \examples{ s <- Rhttpd$new() s$add(RhttpdApp$new( name='summary', app=system.file('exampleApps/summary.R',package='Rook') )) \dontrun{ s$start(quiet=TRUE) s$browse(1) } s$remove(all=TRUE) # Stops the server but doesn't uninstall the app \dontrun{ s$stop() } s$remove(all=TRUE) rm(s) } \keyword{classes} \section{Methods}{ \describe{ \item{\code{new(app, name)}:}{ Creates an object of class \code{RhttpdApp}. Argument \code{app} can be any \code{\link{Rook}} aware object or it can be a location to a file whose source creates a Rook aware object. That object must be named either \code{'app'} or the value of \code{name}. \code{name} is a character vector.} } } Rook/man/File-class.Rd0000644000175100001440000000161412332170455014232 0ustar hornikusers\name{File-class} \Rdversion{1.1} \docType{class} \alias{File-class} \alias{File} \title{Class \code{File}} \description{ A Rook application that serves static files from a root directory, according to the path info of the Rook request. } \examples{ # This example serves all your files in /etc (on UNIX and Mac only). # # Note that when you open the application, you will see the word # 'Forbidden'. "File" doesn't serve directories, so you must amend the # url in the location bar with the file you want to view. Try adding /passwd. s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) } s$add(name="etc",app=File$new('/etc')) \dontrun{ s$browse('etc') # Opens a browser window to the app. } s$remove(all=TRUE) rm(s) } \section{Methods}{ \describe{ \item{\code{new(root):}}{ \code{root} is the name of the directory from where to serve files. } }} \seealso{ \code{\link{Rhttpd}}. } \keyword{classes} Rook/man/RhttpdErrorStream-class.Rd0000644000175100001440000000043712332170455017010 0ustar hornikusers\name{RhttpdErrorStream-class} \Rdversion{1.1} \docType{class} \alias{RhttpdErrorStream-class} \alias{RhttpdErrorStream} \title{Class \code{RhttpdErrorStream}} \description{ An internal class used by \code{\link{Rhttpd}}. } \examples{ showClass("RhttpdErrorStream") } \keyword{classes} Rook/man/suspend_console.Rd0000644000175100001440000000045312332170455015453 0ustar hornikusers\name{suspend_console} \alias{suspend_console} \title{ Suspend the R console } \description{ Calls Sys.sleep in a never-ending while loop to mimic suspension of the R console. } \usage{ suspend_console() } \value{ No value is ever returned. } \seealso{ \code{\link{Rook}}. } \keyword{function} Rook/man/RhttpdInputStream-class.Rd0000644000175100001440000000043712332170455017016 0ustar hornikusers\name{RhttpdInputStream-class} \Rdversion{1.1} \docType{class} \alias{RhttpdInputStream-class} \alias{RhttpdInputStream} \title{Class \code{RhttpdInputStream}} \description{ An internal class used by \code{\link{Rhttpd}}. } \examples{ showClass("RhttpdInputStream") } \keyword{classes} Rook/man/Redirect-class.Rd0000644000175100001440000000101312332170455015105 0ustar hornikusers\name{Redirect-class} \Rdversion{1.1} \docType{class} \alias{Redirect-class} \alias{Redirect} \title{Class \code{Redirect}} \description{ A \code{\link{Rook}} application whose only role is to return an HTTP redirect header to the given url. } \seealso{ See \code{\link{Brewery}} for an example. } \keyword{classes} \section{Methods}{ \describe{ \item{\code{new(url)}:}{ Returns a \code{Rook} object. \code{url} is a character string whose value is a full or relative url to which the browser is redirected.} } } Rook/man/Builder-class.Rd0000644000175100001440000000300112332170455014731 0ustar hornikusers\name{Builder-class} \Rdversion{1.1} \docType{class} \alias{Builder-class} \alias{Builder} \title{Class \code{Builder}} \description{ A convenience object for combining various \code{Middleware} with a default application to create a more complex Rook application. } \examples{ # The following is the Hmisc example. Explore the folder # system.file('exampleApps/Hmisc',package='Rook') for more information. s <- Rhttpd$new() \dontrun{ library(Hmisc) dir.create(file.path(tempdir(),'plots'),showWarnings=FALSE) s$add( name="Hmisc", app=Builder$new( Static$new( urls = c('/css','/images','/javascript'), root = system.file('exampleApps/Hmisc',package='Rook') ), Static$new(urls='/plots',root=tempdir()), Brewery$new( url='/brew', root= system.file('exampleApps/Hmisc',package='Rook'), imagepath=file.path(tempdir(),'plots'), imageurl='../plots/' ), Redirect$new('/brew/useR2007.rhtml') ) ) s$start(quiet=TRUE) s$browse('Hmisc') # Opens a browser window to the application. s$remove(all=TRUE) s$stop() } } \seealso{ \code{\link{Rhttpd}}, \code{\link{Static}}, \code{\link{Brewery}}, and \code{\link{Redirect}}. } \keyword{classes} \section{Methods}{ \describe{ \item{\code{new(...)}:}{ Arguments can be any \code{Middleware} object while the last argument in the list must be a valid \code{Rook} application. That is, it will handle the incoming request without deferring to another application. } } } Rook/man/is_rookable.Rd0000644000175100001440000000071212332170455014537 0ustar hornikusers\name{is_rookable} \alias{is_rookable} \title{ Test for Rookable applications } \description{ A convenience function for testing whether or not objects are either a function or reference class as defined by the Rook specification for applications. } \usage{ is_rookable(app) } \arguments{ \item{app}{ Any R object.} } \value{ Logical determining whether or not argument is Rookable. Not vectorized. } \seealso{ \code{\link{Rook}}. } \keyword{function} Rook/man/Utils-class.Rd0000644000175100001440000000510412332170455014451 0ustar hornikusers\name{Utils-class} \Rdversion{1.1} \docType{class} \alias{Utils-class} \alias{Utils} \title{Class \code{Utils}} \description{ A convenience object for working with various aspects of web requests and responses. } \seealso{ \code{\link{Multipart}}. } \examples{ Utils$bytesize('foo') Utils$escape('foo bar') Utils$unescape('foo+bar') Utils$escape_html('foo ') Utils$escape('foo ') Utils$escape('foo\n') Utils$status_code('OK') Utils$status_code('Found') Utils$status_code('Not Found') x <- Utils$parse_query('foo=1&bar=baz') x Utils$rfc2822(Sys.time()) Utils$timezero() Utils$build_query(x) rm(x) } \keyword{classes} \section{Methods}{ \describe{ \item{\code{bytesize(string=NULL)}:}{ Returns size in bytes for \code{string}, a character vector. } \item{\code{unescape(s=NULL)}:}{ returns the url decoded value of the character vector \code{s}. Also replaces the \code{'+'} character with a space. } \item{\code{status_code(status=NULL)}:}{ returns integer value for the given HTTP \code{status}, which can either be numeric or or a character vector describing the status. Returns \code{as.integer(500)} if \code{status} is NULL.} \item{\code{escape_html(string=NULL)}:}{ replaces \code{"&"}, \code{"<"}, \code{">"}, \code{"'"}, and \code{'"'} with entity equivalents. } \item{\code{raw.match(needle=NULL, haystack=NULL, all=TRUE)}:}{ returns index position of \code{needle} in \code{haystack}. All matched indexes are returned by default. \code{needle} is either a raw vector or character string. \code{haystack} is a raw vector.} \item{\code{parse_query(qs=NULL, d=DEFAULT_SEP)}:}{ Creates a named list from the the query string \code{qs}. \code{d} is the separator value and defaults to \code{'[&;] *'}.} \item{\code{rfc2822(ts=NULL)}:}{ Formats \code{ts} in RFC2822 time. \code{ts} must be a \code{\link{POSIXt}} object.} \item{\code{escape(s=NULL)}:}{ Transforms any non-printable characters found in \code{s} to their percent-encoded equivalents.} \item{\code{build_query(params=NULL)}:}{ Creates a query string from the named list given in \code{params}. } \item{\code{timezero()}:}{ Returns a \code{POSIXct} object set to UNIX epoch. } \item{\code{set_cookie_header(header, key, value, expires, path, domain, secure, httpOnly)}:}{ Sets an HTTP cookie header in the environment \code{header}. All arguments except \code{expires} are length 1 character vectors, while \code{expires} must be a \code{POSIXct} object. } \item{\code{delete_cookie_header(header, key, value, expires, path, domain, secure, httpOnly)}:}{ Deletes the HTTP cookie header. } } } Rook/man/Rook-package.Rd0000644000175100001440000001202112332170455014545 0ustar hornikusers\name{Rook-package} \alias{Rook-package} \alias{Rook} \docType{class} \title{ Rook: A web server interface and package for R } \description{ This help page defines the Rook specification. It borrows heavily from Ruby's Rack project: \url{http://rack.rubyforge.org/}. After reading this document, read the \code{\link{Rhttpd}} help file as it will get you familiar with installing and running \code{Rook} applications. Then explore the example applications located in: \code{system.file('exampleApps',package='Rook')}. } \section{Rook applications}{ A Rook application is an R reference class object that implements a 'call' method or an R closure that takes exactly one argument, an environment, and returns a list with three named elements: \code{'status'}, \code{'headers'}, and \code{'body'}. } \section{Hello World}{ Here is a basic Rook application as a closure that implements 'hello world': \preformatted{ function(env){ body = paste('

Hello World! This is Rook',env$rook.version,'.

') list( status = 200L, headers = list( 'Content-Type' = 'text/html' ), body = body ) } } And the equivalent reference class example: \preformatted{ setRefClass( 'HelloWorld', methods = list( call = function(env){ list( status = 200L, headers = list( 'Content-Type' = 'text/html' ), body = paste('

Hello World! This is Rook',env$rook.version,'.

') ) } ) ) } } \section{The Environment}{ The environment argument is a true R environment object which the application is free to modify. It is required to contain the following variables: \describe{ \item{REQUEST_METHOD}{ The HTTP request method, such as "GET" or "POST". This cannot ever be an empty string, and so is always required. } \item{SCRIPT_NAME}{ The initial portion of the request URL's "path" that corresponds to the application object, so that the application knows its virtual "location". This may be an empty string, if the application corresponds to the "root" of the server.} \item{PATH_INFO}{ The remainder of the request URL's "path", designating the virtual "location" of the request's target within the application. This may be an empty string, if the request URL targets the application root and does not have a trailing slash. This value may be percent-encoded when I originating from a URL.} \item{QUERY_STRING}{ The portion of the request URL that follows the ?, if any. May be empty, but is always required!} \item{SERVER_NAME, SERVER_PORT}{ When combined with SCRIPT_NAME and PATH_INFO, these variables can be used to complete the URL. Note however that HTTP_HOST, if present, should be used in preference to SERVER_NAME for reconstructing the request URL. SERVER_NAME and SERVER_PORT can never be empty strings, and so are always required.} \item{HTTP_ Variables}{ Variables corresponding to the client-supplied HTTP request headers (i.e., variables whose names begin with HTTP_). The presence or absence of these variables should correspond with the presence or absence of the appropriate HTTP header in the request.} } In addition, the environment must include the following Rook-specific variables: \describe{ \item{rook.version}{ This version of Rook.} \item{rook.url_scheme}{'http' or 'https', depending on the request URL.} \item{rook.input}{See \dQuote{The Input Stream} section.} \item{rook.errors}{See \dQuote{The Error Stream} section.} } } \section{The Input Stream}{ The rook.input variable must contain an object created from a reference class that implements \code{read_lines()}, \code{read()}, and \code{rewind()}: \describe{ \item{\code{read_lines(l=-1L)}:}{takes one argument, the number of lines to read. Includes partial ending line.} \item{\code{read(l=-1L)}:}{takes one argument, the number of bytes to read. Returns a raw vector.} \item{\code{rewind()}:}{Rewinds the input stream back to the beginning.} } } \section{The Error Stream}{ The rook.error variable must contain an object created from a reference class that implements \code{flush()} and \code{cat()}: \describe{ \item{\code{flush()}:}{called with no arguments and makes the error stream immediately appear.} \item{\code{cat(...,sep=" ",fill=FALSE,labels=NULL)}:}{called with the same arguments as R's \code{"\link[base]{cat}"} without the \code{file} and append \code{argument}.} } } \section{The Response}{ Rook applications return a list with three named elements: \code{'status'}, \code{'headers'}, and \code{'body'}. \subsection{\code{'status'}}{ An HTTP status value as integer and must be greater than or equal to 100. } \subsection{\code{'headers'}}{ A named list that contains only character values corresponding to valid HTTP headers. } \subsection{\code{'body'}}{ Either a character or raw vector. If the character vector is named with value \code{'file'} then value of the vector is interpreted as the location of a file. }} \author{ Jeffrey Horner } \keyword{package} Rook/man/Brewery-class.Rd0000644000175100001440000000257212332170455014776 0ustar hornikusers\name{Brewery-class} \Rdversion{1.1} \docType{class} \alias{Brewery-class} \alias{Brewery} \title{Class \code{Brewery}} \description{ A \code{\link{Middleware}} class for mapping URLs to a directory of files that are subsequently passed to \code{\link[brew]{brew}}. When a file is brewed, the two variables \code{req} (an object of class \code{\link{Request}}) and \code{res} (an object of class \code{\link{Response}}) are available for use. } \section{Methods}{ \describe{ \item{\code{new(url,root,...):}}{ \code{url} is a character string or \code{\link{regexp}} on which to match, \code{root} is the name of the directory where brew files reside. Named arguments can be passed in via \code{...} and will be available within the scope of each brewed file. } }} \examples{ # # This application runs any file found in tempdir() through brew. # s <- Rhttpd$new() \dontrun{ s$start(quiet=TRUE) } cat("

Random Number: <\%=rnorm(1)\%>

", file=file.path(tempdir(),"index.html")) s$add(name="random", app=Builder$new( Brewery$new(url="/",root=tempdir()), Redirect$new("/index.html") ) ) \dontrun{ s$browse('random') # Opens a browser window to the app. } file.remove(file.path(tempdir(),"index.html")) s$remove(all=TRUE) rm(s) } \seealso{ \code{\link{Rhttpd}}, \code{\link{Builder}}, \code{\link{Redirect}}, and \code{\link[brew]{brew}}. } \keyword{classes}