Rook/0000755000176200001440000000000014332143313011161 5ustar liggesusersRook/NAMESPACE0000644000176200001440000000104414331105373012402 0ustar liggesusersexportClass(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/README.md0000644000176200001440000001134714331571630012454 0ustar liggesusers[![](https://circleci.com/gh/evanbiederstedt/Rook.svg?style=svg)](https://app.circleci.com/pipelines/github/evanbiederstedt/Rook) [![CRAN status](https://www.r-pkg.org/badges/version/Rook)](https://cran.r-project.org/package=Rook) [![CRAN downloads](https://cranlogs.r-pkg.org/badges/Rook)](https://cran.r-project.org/package=Rook) **NOTE:** This is a fork of the original project at https://github.com/jeffreyhorner/Rook The original maintainer didn't respond to fix various issues which required the package to be removed from CRAN. This fork fixes those issues. As a consequence, I ([@evanbiederstedt](https://github.com/evanbiederstedt)) am the new maintainer. Rook: A web server interface for R ======================================= This specification 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 reference 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/man/0000755000176200001440000000000014331105373011737 5ustar liggesusersRook/man/File-class.Rd0000644000176200001440000000161414331105373014212 0ustar liggesusers\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/Rook-package.Rd0000644000176200001440000001202314331573753014542 0ustar liggesusers\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{https://github.com/rack/rack}. 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/Response-class.Rd0000644000176200001440000000317414331105373015134 0ustar liggesusers\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/Builder-class.Rd0000644000176200001440000000300114331105373014711 0ustar liggesusers\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/Server.Rd0000644000176200001440000000050514331105373013474 0ustar liggesusers\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/Mime-class.Rd0000644000176200001440000000123714331105373014223 0ustar liggesusers\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/Static-class.Rd0000644000176200001440000000107214331105373014560 0ustar liggesusers\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/Utils-class.Rd0000644000176200001440000000510414331105373014431 0ustar liggesusers\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/is_rookable.Rd0000644000176200001440000000071214331105373014517 0ustar liggesusers\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/Multipart-class.Rd0000644000176200001440000000234514331105373015316 0ustar liggesusers\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/RhttpdInputStream-class.Rd0000644000176200001440000000043714331105373016776 0ustar liggesusers\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/RhttpdErrorStream-class.Rd0000644000176200001440000000043714331105373016770 0ustar liggesusers\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/Redirect-class.Rd0000644000176200001440000000101314331105373015065 0ustar liggesusers\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/RhttpdApp-class.Rd0000644000176200001440000000322314331105373015237 0ustar liggesusers\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/Brewery-class.Rd0000644000176200001440000000257214331105373014756 0ustar liggesusers\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} Rook/man/App-class.Rd0000644000176200001440000000131214331105373014046 0ustar liggesusers\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/suspend_console.Rd0000644000176200001440000000045314331105373015433 0ustar liggesusers\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/Middleware-class.Rd0000644000176200001440000000352214331105373015410 0ustar liggesusers\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/URLMap-class.Rd0000644000176200001440000000244214331105373014433 0ustar liggesusers\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/Request-class.Rd0000644000176200001440000001560414331105373014767 0ustar liggesusers\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/Rhttpd-class.Rd0000644000176200001440000001003014331105373014570 0ustar  liggesusers\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/DESCRIPTION0000644000176200001440000000143414332143313012671 0ustar  liggesusersPackage: Rook
Title: HTTP Web Server for R
Version: 1.2
Date: 2022-11-05
Description: An HTTP web server for R with a documented API to interface between R and the server. The documentation contains the Rook specification and details for building and running Rook applications. To get started, be sure and read the 'Rook' help file first.
Encoding: UTF-8
Depends: R (>= 2.13.0)
Imports: utils, tools, methods, brew
License: GPL-2
LazyLoad: yes
URL: https://github.com/evanbiederstedt/rook
BugReports: https://github.com/evanbiederstedt/rook/issues
Author: Jeffrey Horner [aut], Evan Biederstedt [aut, cre]
Maintainer: Evan Biederstedt 
NeedsCompilation: yes
Packaged: 2022-11-05 23:55:46 UTC; evanbiederstedt
Repository: CRAN
Date/Publication: 2022-11-07 08:50:19 UTC
Rook/src/0000755000176200001440000000000014331571624011761 5ustar  liggesusersRook/src/rook.c0000644000176200001440000000315614331571624013104 0ustar  liggesusers#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) {
      SEXP result = PROTECT(allocVector(INTSXP,0));
      UNPROTECT(1);

      return result;
   }

   k = 0;
   ans = PROTECT(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 = PROTECT(allocVector(INTSXP,k));
   while(k) {k--;INTEGER(newans)[k] = INTEGER(ans)[k];}

   UNPROTECT(2);
   return newans;
}

R_CallMethodDef CallEntries[]  = {
   {"rawmatch", (DL_FUNC) &rawmatch, 3},
   {NULL, NULL, 0}
};

void R_init_Rook(DllInfo *dll) {
   R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
   R_useDynamicSymbols(dll, FALSE);
}
Rook/R/0000755000176200001440000000000014331105373011365 5ustar  liggesusersRook/R/Request.R0000644000176200001440000001272214331105373013144 0ustar  liggesusersRequest <- 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/App.R0000644000176200001440000000131014331105373012223 0ustar  liggesusersis_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/utils.R0000644000176200001440000005271314331105373012660 0ustar  liggesusersUtils <- 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 { 
              paramName <- substr(i,1,m-1)
              ilen <- nchar(i)
              if (ilen == m) {
                params$params[[paramName]] <- ''
              } else {
                # handle array parameters
                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/File.R0000644000176200001440000000434314331105373012373 0ustar  liggesusersFile <- 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/Redirect.R0000644000176200001440000000047214331105373013254 0ustar  liggesusersRedirect <- 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/Brewery.R0000644000176200001440000000266414331105373013137 0ustar  liggesusersBrewery <- 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/R/Response.R0000644000176200001440000000275214331105373013314 0ustar  liggesusersResponse <- 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/Rhttpd.R0000644000176200001440000003017214331105373012760 0ustar  liggesusersRhttpdApp <- setRefClass(
    'RhttpdApp',
    fields = c('app','name','path','appEnv'),
    methods = list(
       initialize = function(app=NULL,name=NULL,...){
          if (is.null(name) || !is.character(name))
             base::stop("Need a proper app 'name'")

          .self$name <- name

          if (is.character(app) && file.exists(app)){
             oldwd <- setwd(dirname(app))
             on.exit(setwd(oldwd))
             appEnv <<- new.env(parent=globalenv())
             appEnv$.appFile <<- normalizePath(basename(app))
             appEnv$.mtime <<- as.integer(file.info(appEnv$.appFile)$mtime)
             sys.source(appEnv$.appFile,envir=.self$appEnv)

             if (exists(.self$name,.self$appEnv,inherits=FALSE))
                .self$app <- get(.self$name,.self$appEnv)
             else if (exists('app',.self$appEnv,inherits=FALSE))
                .self$app <- get('app',.self$appEnv)
             else
                base::stop("Cannot find a suitable app in file ",app)

          } else {
             .self$app <- app
             .self$name <- name
             .self$appEnv <- NULL
          }

          if (!is_rookable(.self$app))
             base::stop("App is not rookable'")

          .self$path <- ifelse(.self$name=='httpd','', paste('/custom',.self$name,sep='/'))
          callSuper(...)
       }
   )
)

RhttpdInputStream <- setRefClass(
    'RhttpdInputStream',
    fields = c('postBody','pos'),
    methods = list(
	initialize = function(postBody=NULL,...){
	    if (is.null(postBody)) {
		postBody <<- raw(0) # empty post body
	    } else if (is.character(postBody)){
		postBody <<- charToRaw(paste(names(postBody),postBody,sep='=',collapse='&'))
	    } else {
		postBody <<- postBody
	    }
	    pos <<- 1
	    callSuper(...)
	},
	read_lines = function(n = -1L){
	    if (n==0 || pos > length(postBody)) return(character())
	    nls <- which(charToRaw('\n')==postBody[pos:length(postBody)])
	    rv <- character(ifelse(n>-1L,n,0))
	    lc <- 1
	    for (i in nls){
		rv[lc] <- rawToChar(postBody[pos:(pos+i-1)])
		pos <<- pos + pos + i
		lc <- lc + 1
		if (pos > length(postBody) || lc > n)
		    break
	    }
	    if (lc <= n && pos <= length(postBody))
		rv[lc] <- rawToChar(postBody[pos:length(postBody)])
	    rv
	},
	read = function(l = -1L){
	    if (l == 0 || pos >= length(postBody)) return(raw())
	    if (l < 0){
		rv <- postBody[pos:length(postBody)]
		pos <<- length(postBody)
		return(rv)
	    } else {
		rv <- postBody[pos:(pos+(l-1))]
		pos <<- pos + l
		return(rv)
	    }
	},
	rewind = function(){
	    pos <<- 1
	}
    )
)

RhttpdErrorStream <- setRefClass(
    'RhttpdErrorStream',
    methods = list(
	flush = function() { base::flush(stderr()) },
	cat = function(...,sep=" ",fill=FALSE,labels=NULL)
	{ base::cat(...,sep=sep,fill=fill,labels=labels,file=stderr()) }
    )
)

Rhttpd <- setRefClass(
    'Rhttpd',
    fields = c('appList','listenAddr','httpdOrig','listenPort'),
    methods = list(
	initialize = function(...){
	    appList <<- list()
	    listenAddr <<- '127.0.0.1'
	    listenPort <<- 0L
	    callSuper(...)
	},
	finalize = function(){
	    if (length(appList) == 0) return()
	    for (i in rev(1:length(appList))){
		remove(appList[[i]])
	    }
	},
	full_url = function(i){
	    paste('http://',listenAddr,':',listenPort,appList[[i]]$path,sep='')
	},
	launch = function(...){
	    .self$start(quiet=TRUE)		
	    # Try to create a new app from the supplied arguments
	    app <- RhttpdApp$new(...)
	    if (add(app)){
		appName <- app$name
		browseURL(full_url(which(appName == names(appList))))
		invisible()
	    } else {
		base::stop("No app to launch")
	    }
	},
	open = function(x){
	    if (missing(x)) return(print())
	    if (is.numeric(x) || is.integer(x)){
		x <- as.integer(x)
		if (!is.null(appList[[x]]))
		    return(invisible(browseURL(full_url(x))))
		else
		    base::stop("No app at index ",x)
	    } else if (is.character(x)){
		for (i in 1:length(appList)){
		    if (appList[[i]]$name==x){
			return(invisible(browseURL(full_url(x))))
		    }
		}
		base::stop("No app named",x)
	    }
	    base::stop("Argument must be an integer or character")
	},
	browse = function(x) open(x),
   start = function(listen='127.0.0.1',port=getOption('help.ports'),quiet=FALSE){

      if(nzchar(Sys.getenv("R_DISABLE_HTTPD"))) {
         warning("httpd server disabled by R_DISABLE_HTTPD", immediate. = TRUE)
         utils::flush.console()
         return(invisible())
      }

      if(grepl('rstudio',base::.Platform$GUI,ignore.case=TRUE)){
         # RStudio has already set up host and port
         listenPort <<- tools:::httpdPort
         if (!missing(port))
            warning("RStudio has already started the web server on port ",tools:::httpdPort)
         return(invisible())
      }

      if (!missing(listen) && listen != '127.0.0.1'){
         listen <- '127.0.0.1'
         warning("This version of Rook can only listen on the loopback device.");
      }

      if (!missing(port)){
         oldPorts <- getOption('help.ports')
         on.exit(options(help.ports=oldPorts))
         options(help.ports=port)
      }

      if (length(appList) == 0)
         add(RhttpdApp$new(system.file('exampleApps/RookTestApp.R',package='Rook'),name='RookTest'))


      listenPort <<- startDynamicHelp(TRUE)

      if (listenPort == 0){
         base::stop("The internal web server could not be started!")
      }

      if (!quiet){
         cat('\nServer started on host',listen,'and port',listenPort,'. App urls are:\n\n')
         invisible(lapply(names(appList),function(i){
            cat('\thttp://',listen,':',listenPort,appList[[i]]$path,'\n',sep='')
               }))
      }
      invisible()
   },

	stop = function(){
	    listenPort <<- startDynamicHelp(FALSE)
	},
	add = function(app=NULL,name=NULL){

	    if (!inherits(app,'RhttpdApp'))
		app <- RhttpdApp$new(name=name,app=app)
	    if (!inherits(app,'RhttpdApp'))
		base::stop("Need an RhttpdApp object")

	    appList[[app$name]] <<- app
	    if(app$name=='httpd'){
		base::stop("Rook no longer supports assignment to tools:::httpd")
		#.self$httpdOrig <- tools:::httpd
		#assignInNamespace(
		#    app$name,
		#    function(path,query,postBody,headers) 
		#	.self$handler(app$name,path,query,postBody,headers), 
		#    'tools'
		#)
	    } else {
		assign(
		    app$name, 
		    function(path,query,postBody,headers) 
			.self$handler(app$name,path,query,postBody,headers), 
		    tools:::.httpd.handlers.env
		)
	    }

	    invisible(TRUE)
	},
	remove = function(app=NULL,all=FALSE){
	    if (all==TRUE){
		lapply(names(appList),remove)
		return(invisible(TRUE))
	    }
	    if (inherits(app,'RhttpdApp'))
		name <- app$name
	    else if (is.character(app))
		name <- app
	    else if (is.numeric(app) || is.integer(app))
		name <- appList[[app]]$name
	    else
		base::stop("Can only remove by object, app name, or index.")

	    if (is.null(appList[[name]])) return(FALSE)

	    appList[[name]] <<- NULL
	    ret <- FALSE
	    if(name=='httpd' && !is.null(httpdOrig)){
		tools:::httpd <- httpdOrig
		ret <- TRUE
	    } else if (exists(name,tools:::.httpd.handlers.env)){
		rm(list=name,pos=tools:::.httpd.handlers.env)
		ret <- TRUE
	    }
	    invisible(ret)
	},
	parse_headers = function(headers,env){

	    hlines <- strsplit(rawToChar(headers),'\n')[[1]]

	    lapply(
		strsplit(hlines,': '),
		function(x) {
		    assign(
			paste('HTTP_',gsub('-','_',gsub('(\\w+)','\\U\\1',x[1],perl=TRUE)),sep=''),
			x[2],
			env
			)
		}
	    )
	},
   build_env = function(appPath,path,query,postBody,headers){
      env <- new.env(hash=TRUE,parent=emptyenv())

      parse_headers(headers,env)

      # remove HTTP_ from content length and type
      if (exists('HTTP_CONTENT_LENGTH',env) && exists('HTTP_CONTENT_TYPE',env)){
         assign('CONTENT_LENGTH',env$`HTTP_CONTENT_LENGTH`,env)
         assign('CONTENT_TYPE',env$`HTTP_CONTENT_TYPE`,env)
         rm('HTTP_CONTENT_LENGTH','HTTP_CONTENT_TYPE',envir=env)
      }

      assign('SCRIPT_NAME',appPath,env)
      assign('PATH_INFO',sub(appPath,'',path,fixed=TRUE),env)

      # The R internal web server unescapes the query, so in order
      # abid the Rook spec, we have to do things in reverse:
      #
      # escape the query object so that subsequent URI building
      # methods will add the correct query string.
      assign('QUERY_STRING',
         ifelse(is.null(query),
            '',
            paste(names(query),Utils$escape(query),sep='=',collapse='&')
            ),
         env
         )
      
      if(exists("HTTP_REQUEST_METHOD", env)){
        assign('REQUEST_METHOD',get("HTTP_REQUEST_METHOD", env) ,env)
      } else {      
        assign('REQUEST_METHOD',ifelse(is.null(postBody),'GET','POST'),env)
      }

      hostport <- strsplit(get('HTTP_HOST',env),':',fixed=TRUE)[[1]]

      assign('SERVER_NAME',hostport[1],env)
      assign('SERVER_PORT',hostport[2],env)

      assign('rook.version',packageDescription('Rook',fields='Version'),env)
      assign('rook.url_scheme','http',env)
      assign('rook.input',RhttpdInputStream$new(postBody),env)
      assign('rook.errors',RhttpdErrorStream$new(),env)

      if (debug()>1)
         str(as.list(env))
      env
   },
   handler = function(appName,path,query,postBody,headers){
      if (debug()>0){
         cat('Request:',path,'\n')
      }
      app <- appList[[appName]]
      if (is.null(app)){
         base::stop("No app installed named ",appName)
         return()
      }
      if (!is.null(app$appEnv)){
         file_path = app$appEnv$.appFile
         mtime <- as.integer(file.info(file_path)$mtime)


         if (mtime > app$appEnv$.mtime){
            add(name=appName,app=file_path)
         }
         app <- appList[[appName]]
         if (is.null(app)){
            stop("No app installed named ",appName)
            return()
         }

         oldwd <- setwd(dirname(app$appEnv$.appFile))
         on.exit(setwd(oldwd))
      }
      env <- build_env(app$path,path,query,postBody,headers)
      if (is(app$app,'function')) {
         res <- try(app$app(env))
      } else {
         res <- try(app$app$call(env))
      }
      if (inherits(res,'try-error') || (is.character(res) && length(res) == 1))
         res
      else {
         # Only need to handle the case where body is a vector of strings
         # We presume that if res$body is a location to a file then the
         # app has so named it. We also presume that res$body may be
         # a raw vector, but we let the internal web server deal with that.
         if (is.character(res$body) && length(res$body) > 1){
            res$body <- paste(res$body,collapse='')
         }
         contentType <- res$headers$`Content-Type`;
         res$headers$`Content-Type` <- NULL;

         # The internal web server expects a list like the below,
         # and the position of each element is important.
         ret <- list(
            payload = res$body,
            `content-type` = contentType,
            headers = NULL,
            `status code` = res$status
         )

         # Change the name of payload to file in the case that
         # payload *is* a filename
         if (!is.null(names(res$body)) && names(res$body)[1] == 'file'){
            names(ret) <- c('file',names(ret)[-1])
         }

         # Rhttpd doesn't allow Content-Length in the headers, so delete
         # it as well
         res$headers$`Content-Length` <- NULL;
         if (length(res$headers)>0){
            ret$headers <- paste(names(res$headers),': ',res$headers,sep='')
         }

         if (debug()>0){
            cat('Response:\n')
            str(ret)
         }
         ret
      }
   },
	print = function() {
	    if (listenPort > 0){
		cat("Server started on ",listenAddr,":",listenPort,"\n",sep='')
	    } else {
		cat("Server stopped\n")
	    }
	    if (length(appList) == 0){
		cat("No applications installed\n")
		return(invisible())
	    }
	    len <- max(nchar(names(appList)))
	    for (i in 1:length(appList)){
		appName <- sprintf(paste('%-',len,'s',sep=''),names(appList)[i])
		cat('[',i,'] ',appName,' ',full_url(i),'\n',sep='')
	    }
	    cat("\nCall browse() with an index number or name to run an application.\n")
	    invisible()
	},
	show = function() print(),
	debug = function(){
	    d <- getOption('Rhttpd_debug')
	    if (!is.null(d)) as.integer(d)
	    else 0
	}
    )
)
Rook/R/URLMap.R0000644000176200001440000000156714331105373012621 0ustar  liggesusersURLMap <- 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/Rookery.R0000644000176200001440000000743614331105373013154 0ustar  liggesusers.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/Static.R0000644000176200001440000000071014331105373012735 0ustar liggesusersStatic <- 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/onLoad.R0000644000176200001440000000055514331105373012731 0ustar liggesusers# 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/suspend.R0000644000176200001440000000050014331105373013164 0ustar liggesuserssuspend_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/Builder.R0000644000176200001440000000060314331105373013075 0ustar liggesusersBuilder <- 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/MD50000644000176200001440000000646714332143313011506 0ustar liggesusers9e7992d2dd2d1e14be1fa481fcfcc594 *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 226a8d55071196fa1bff323dcd847f74 *R/Rhttpd.R 388278765c045d966a5954a7a3e083fe *R/Rookery.R e6952d21f4eb6d2825192f527fa91d44 *R/Static.R 4c6f94bf4d06905a12222e092509cd9e *R/URLMap.R f96de9e408627b7bae010551bfe82c05 *R/onLoad.R ca1ab77a4d132f473597c2f0654a6863 *R/suspend.R 3ac1f067bc79fc35a8784ba388c18938 *R/utils.R 7727480eeec5244c1db39a50feb628e5 *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 37c3bfa7a9676283b69f24e689f89aa1 *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 870020f795f8ffbaea8cef7c79afca02 *src/rook.c Rook/inst/0000755000176200001440000000000014331105373012141 5ustar liggesusersRook/inst/exampleApps/0000755000176200001440000000000014331105373014420 5ustar liggesusersRook/inst/exampleApps/arrayparams.R0000644000176200001440000000360514331105373017071 0ustar liggesusersapp <- 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/RookTestApp.R0000644000176200001440000000314014331105373016754 0ustar liggesusersapp <- 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.R0000644000176200001440000000070414331105373016717 0ustar liggesusersapp <- 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/rnorm.R0000644000176200001440000000211714331105373015701 0ustar liggesusersapp <- 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/helloworldref.R0000644000176200001440000000035014331105373017411 0ustar liggesusersapp <- setRefClass( 'HelloWorld', methods = list( call = function(env){ list( status=200, headers = list( 'Content-Type' = 'text/html' ), body = paste('

Hello World!

') ) } ) )$new() Rook/inst/exampleApps/exampleData/0000755000176200001440000000000014331105373016645 5ustar liggesusersRook/inst/exampleApps/exampleData/error.html0000644000176200001440000000011514331105373020661 0ustar liggesusers

ERROR! <%=dataset%> not found.

Rook/inst/exampleApps/exampleData/config.R0000644000176200001440000001174414331105373020244 0ustar liggesuserslibrary(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.html0000644000176200001440000000114114331105373021155 0ustar liggesusers<% 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/exampleData/index.html0000644000176200001440000000135614331105373020647 0ustar liggesusers 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/Hmisc/0000755000176200001440000000000014331105373015463 5ustar liggesusersRook/inst/exampleApps/Hmisc/config.R0000644000176200001440000000056614331105373017062 0ustar liggesuserslibrary(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/0000755000176200001440000000000014331105373017631 5ustar liggesusersRook/inst/exampleApps/Hmisc/javascript/useR2007.js0000644000176200001440000000114614331105373021420 0ustar liggesusersfunction 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/images/0000755000176200001440000000000014331105373016730 5ustar liggesusersRook/inst/exampleApps/Hmisc/images/spinner.gif0000644000176200001440000000376514331105373021110 0ustar liggesusersGIF89a鵵<<<򭭭۪׻&&&عˮ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/brew/0000755000176200001440000000000014331105373016422 5ustar liggesusersRook/inst/exampleApps/Hmisc/brew/useR2007.rhtml0000644000176200001440000000642514331105373020730 0ustar liggesusers 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.rhtml0000644000176200001440000000130414331105373021430 0ustar liggesusers<% 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/Hmisc/brew/useR2007plot.rhtml0000644000176200001440000000143614331105373021624 0ustar liggesusers Rook/inst/exampleApps/Hmisc/css/0000755000176200001440000000000014331105373016253 5ustar liggesusersRook/inst/exampleApps/Hmisc/css/useR2007.css0000644000176200001440000000344014331105373020215 0ustar liggesusersbody { 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/summary.R0000644000176200001440000000144114331105373016240 0ustar liggesusersapp <- 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/RJSONIO.R0000644000176200001440000000246714331105373015677 0ustar liggesuserslibrary(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/inst/servers/0000755000176200001440000000000014331105373013632 5ustar liggesusersRook/inst/servers/rApache.R0000644000176200001440000001127314331105373015324 0ustar liggesusers.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 } )