Start of rApache support

Rook/NAMESPACE

@@ -9,4 +9,5 @@ export(File,Static,Builder,App,Middleware,URLMap)
 exportClass(Brewery,Redirect)
 export(Brewery,Redirect)
 export(is_rookable)
+export(Server)
 useDynLib(Rook,.registration=TRUE)

Rook/R/Rhttpd.R

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

Rook/R/onLoad.R

@@ -0,0 +1,12 @@
+# 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/inst/servers/rApache.R

@@ -0,0 +1,106 @@
+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)
+	    })
+
+	    cat(paste(names(env),collapse=' '),file=stderr())
+
+	    assign('CONTENT_LENGTH',SERVER$clength,env)
+	    assign('CONTENT_TYPE',SERVER$content_type,env)
+
+	    assign('PATH_INFO',SERVER$path_info,env)
+	    assign('SCRIPT_NAME',sub(SERVER$path_info,'',SERVER$uri),env)
+	    assign('QUERY_STRING',SERVER$args,env)
+	    assign('REQUEST_METHOD',SERVER$method,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',
+		strsplit(get('HTTP_ORIGIN',env),':',fixed=TRUE)[[1]][1]
+		,env
+	    )
+	    assign(
+		'rook.input',
+		setRefClass(
+		    'rApacheInputStream',
+		    methods = list(
+			initialize = function(...){
+			    callSuper(...)
+			},
+			read_lines = function(n = -1L){
+			    if (n<=0) return(character())
+			    readLines(n=n,warn=FALSE)
+			},
+			read = function(l = -1L){
+			    if (l <= 0 ) return(raw())
+			    receiveBin(l)
+			},
+			rewind = function(){
+			    warning("rApache doesn't support rewind()")
+			}
+		    )
+		)$new(),
+		env
+	    )
+
+	    assign(
+		'rook.errors',
+		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()) }
+		    )
+		)$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)
+	    }
+
+	    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 {
+		sendbin(res$body)
+	    }
+
+	    res$status
+	}
+    )
+)$new()