├── LICENSE ├── R ├── zzz.R ├── prairie.R ├── response-utils.R ├── request-header.R ├── body.R ├── jsonify.R ├── response-header.R ├── utils.R ├── status.R ├── mockup.R ├── request-request-line.R ├── application.R ├── request.R ├── response.R └── route.R ├── .Rbuildignore ├── inst └── dull_logo.png ├── tests ├── testthat.R └── testthat │ ├── sample-route.R │ ├── whoops-route.R │ ├── sample-response.html │ ├── test-response-functions.R │ ├── test-mockup.R │ ├── test-application-object.R │ ├── test-request-object.R │ ├── test-jsonify.R │ ├── test-route-functions.R │ ├── test-utils.R │ ├── test-request-functions.R │ ├── test-route-object.R │ └── test-response.R ├── .gitignore ├── .travis.yml ├── man ├── as.list.response.Rd ├── print.application.Rd ├── run.Rd ├── print.request.Rd ├── reason_phrase.Rd ├── print.response.Rd ├── status.Rd ├── query.Rd ├── print.route.Rd ├── prairie.Rd ├── as.request.Rd ├── method.Rd ├── simpleHtmlTable.Rd ├── mockup.Rd ├── request-headers.Rd ├── response-headers.Rd ├── body.Rd ├── uri.Rd ├── json.Rd ├── application.Rd ├── as.route.Rd ├── response.Rd ├── as.response.Rd ├── request.Rd └── route.Rd ├── NAMESPACE ├── DESCRIPTION └── README.md /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2015 2 | COPYRIGHT HOLDER: Nathan Teetor 3 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(libname, pkgname) { 2 | 3 | } 4 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^prairie\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | -------------------------------------------------------------------------------- /inst/dull_logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nteetor/prairie/HEAD/inst/dull_logo.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(prairie) 3 | 4 | test_check("prairie") 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | README.html 5 | prairie.Rproj 6 | .DS_Store 7 | -------------------------------------------------------------------------------- /tests/testthat/sample-route.R: -------------------------------------------------------------------------------- 1 | route( 2 | 'nothing', 3 | 'to', 4 | function(req) { 5 | 'see here' 6 | } 7 | ) 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Sample .travis.yml for R projects 2 | 3 | language: r 4 | warnings_are_errors: true 5 | sudo: required 6 | r_github_packages: 7 | - jimhester/covr 8 | 9 | after_success: 10 | - Rscript -e 'covr::codecov()' 11 | -------------------------------------------------------------------------------- /tests/testthat/whoops-route.R: -------------------------------------------------------------------------------- 1 | string <- 'how did this get here?' 2 | 3 | route( 4 | 'GET', 5 | '^bridge/to/[a-z]+$', 6 | function() { 7 | response() 8 | } 9 | ) 10 | 11 | post_amble <- '10 days and thirty minutes prior ...' 12 | -------------------------------------------------------------------------------- /R/prairie.R: -------------------------------------------------------------------------------- 1 | #' @seealso \code{\link{app}}, \code{\link{route}}, \code{\link{request}}, and 2 | #' \code{\link{response}} 3 | #' 4 | #' @importFrom httpuv runServer encodeURI 5 | #' @importFrom stringr str_match_all 6 | #' 7 | #' @name prairie 8 | #' @docType package 9 | "_PACKAGE" 10 | -------------------------------------------------------------------------------- /tests/testthat/sample-response.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Is this where title goes? 4 | 5 | 6 | I knew of a man from Quill
7 | Who ate nothing but grits and krill
8 | Vigorously, spoon by spoon
9 | He could've fed a platoon
10 | But instead he had his fill
11 | 12 | 13 | -------------------------------------------------------------------------------- /R/response-utils.R: -------------------------------------------------------------------------------- 1 | #' Coerce Response to List 2 | #' 3 | #' Used to format a response object in the acceptable httpuv format. 4 | #' 5 | #' @param x A response object. 6 | #' @param \dots Ignored. 7 | #' 8 | #' @keywords internal 9 | #' @export 10 | #' @name as.list.response 11 | as.list.response <- function(x, ...) { 12 | list( 13 | status = x$status_code, 14 | headers = x$headers, 15 | body = x$body 16 | ) 17 | } 18 | -------------------------------------------------------------------------------- /man/as.list.response.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/response-utils.R 3 | \name{as.list.response} 4 | \alias{as.list.response} 5 | \title{Coerce Response to List} 6 | \usage{ 7 | \method{as.list}{response}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A response object.} 11 | 12 | \item{\dots}{Ignored.} 13 | } 14 | \description{ 15 | Used to format a response object in the acceptable httpuv format. 16 | } 17 | \keyword{internal} 18 | -------------------------------------------------------------------------------- /man/print.application.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/application.R 3 | \name{print.application} 4 | \alias{print.application} 5 | \alias{format.application} 6 | \title{Print an Application} 7 | \usage{ 8 | \method{print}{application}(x, ...) 9 | 10 | \method{format}{application}(x, ...) 11 | } 12 | \arguments{ 13 | \item{x}{An application.} 14 | 15 | \item{\ldots}{Ignored.} 16 | } 17 | \description{ 18 | Prints an application. 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/run.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/application.R 3 | \name{run} 4 | \alias{run} 5 | \title{Start Up a Prairie Application} 6 | \usage{ 7 | run(app, host, port) 8 | } 9 | \arguments{ 10 | \item{app}{An application object.} 11 | 12 | \item{host}{A character string specifying the host name.} 13 | 14 | \item{port}{An numeric specifying the port number.} 15 | } 16 | \description{ 17 | Run an application at host \code{host} on port number \code{port}. 18 | } 19 | -------------------------------------------------------------------------------- /man/print.request.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request.R 3 | \name{print.request} 4 | \alias{print.request} 5 | \alias{format.request} 6 | \title{Printing Requests} 7 | \usage{ 8 | \method{print}{request}(x, ...) 9 | 10 | \method{format}{request}(x, ...) 11 | } 12 | \arguments{ 13 | \item{x}{A request object.} 14 | 15 | \item{\ldots}{Ignored.} 16 | } 17 | \description{ 18 | Print a request object. 19 | } 20 | \examples{ 21 | print(request()) 22 | 23 | } 24 | \seealso{ 25 | \code{\link{request}} 26 | } 27 | \keyword{internal} 28 | -------------------------------------------------------------------------------- /man/reason_phrase.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/status.R 3 | \name{reason_phrase} 4 | \alias{reason_phrase} 5 | \title{Status Code Reason Phrase} 6 | \usage{ 7 | reason_phrase(code) 8 | } 9 | \arguments{ 10 | \item{code}{An HTTP status code.} 11 | } 12 | \value{ 13 | The corresponding description of \code{code}, otherwise the empty 14 | string. 15 | } 16 | \description{ 17 | Get the corresponding reason phrase for a status code. 18 | } 19 | \examples{ 20 | reason_phrase(200) 21 | reason_phrase('404') 22 | 23 | reason_phrase(531) 24 | 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /man/print.response.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/response.R 3 | \name{print.response} 4 | \alias{print.response} 5 | \alias{format.response} 6 | \title{Printing Responses} 7 | \usage{ 8 | \method{print}{response}(x, ...) 9 | 10 | \method{format}{response}(x, ...) 11 | } 12 | \arguments{ 13 | \item{x}{Object of class \code{response}.} 14 | 15 | \item{\ldots}{Ignored.} 16 | } 17 | \description{ 18 | Print a response object. 19 | } 20 | \details{ 21 | Formats the response as an HTTP response. 22 | } 23 | \seealso{ 24 | \code{\link{response}} 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /tests/testthat/test-response-functions.R: -------------------------------------------------------------------------------- 1 | context('response functions / utils') 2 | 3 | test_that('response coerces to list', { 4 | res <- response() 5 | status(res) <- 405 6 | body(res) <- 'hello, world' 7 | res[['Content-Length']] <- 3030 8 | 9 | reslive <- as.list(res) 10 | 11 | expect_true(reslive %has_name% 'status') 12 | expect_true(reslive %has_name% 'headers') 13 | expect_true(reslive %has_name% 'body') 14 | 15 | expect_equal(reslive$status, 405) 16 | expect_equal(reslive$headers, list(`Content-Type` = 'text/plain', `Content-Length` = 3030)) 17 | expect_equal(reslive$body, 'hello, world') 18 | }) 19 | -------------------------------------------------------------------------------- /tests/testthat/test-mockup.R: -------------------------------------------------------------------------------- 1 | context('route mockups') 2 | 3 | test_that('print.mockup calls underlying print.route', { 4 | simple_route <- route('get', '/qwerty', function(req) response()) 5 | simple_route_m <- mockup(simple_route) 6 | 7 | route_output <- capture.output(print(simple_route)) 8 | mockup_output <- capture.output(print(simple_route_m)) 9 | 10 | expect_equal(route_output, mockup_output) 11 | }) 12 | 13 | test_that('mockup throws error if route does not return response', { 14 | bad_route <- route('post', '^/on/sunday$', function(req) 'whoops!') 15 | bad_mockup <- mockup(bad_route) 16 | 17 | expect_warning(bad_mockup('post', '/on/sunday'), 'handler returned object of class character') 18 | }) -------------------------------------------------------------------------------- /man/status.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/status.R 3 | \name{status} 4 | \alias{status} 5 | \alias{status<-} 6 | \title{HTTP Response Status Code} 7 | \usage{ 8 | status(x) 9 | 10 | status(x) <- value 11 | } 12 | \arguments{ 13 | \item{x}{A response object.} 14 | 15 | \item{value}{An HTTP status code, \code{1xx} through \code{5xx}, see 16 | \code{\link{response}} for details.} 17 | } 18 | \description{ 19 | Get or set the status code of a response object. 20 | } 21 | \examples{ 22 | # create a new response 23 | res <- response() 24 | 25 | # default response status 26 | status(res) # 200 27 | 28 | # set the response status 29 | status(res) <- 301 30 | status(res) 31 | 32 | } 33 | -------------------------------------------------------------------------------- /man/query.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request-request-line.R 3 | \name{query} 4 | \alias{query} 5 | \title{Request Query} 6 | \usage{ 7 | query(x) 8 | } 9 | \arguments{ 10 | \item{x}{A request object.} 11 | } 12 | \description{ 13 | Get a request query. 14 | } 15 | \examples{ 16 | # This route prints out all query key, value pairs 17 | route( 18 | 'ALL', 19 | '^$', 20 | function(req) { 21 | if (!is.null(query(req))) { 22 | for (n in names(query(req))) { 23 | print(paste(n, query(req)[[n]])) 24 | } 25 | } else { 26 | print('The request did not contain a query') 27 | } 28 | 29 | response() 30 | } 31 | ) 32 | 33 | } 34 | \seealso{ 35 | Other HTTP request request-line: \code{\link{method}}, 36 | \code{\link{uri}} 37 | } 38 | -------------------------------------------------------------------------------- /man/print.route.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/route.R 3 | \name{print.route} 4 | \alias{print.route} 5 | \alias{format.route} 6 | \title{Printing Routes and Mockups} 7 | \usage{ 8 | \method{print}{route}(x, ...) 9 | 10 | \method{format}{route}(x, ...) 11 | } 12 | \arguments{ 13 | \item{x}{A route or route mockup.} 14 | 15 | \item{\ldots}{Ignored.} 16 | } 17 | \description{ 18 | Prints a route or mockup. Printing a mockup prints the underlying route. 19 | } 20 | \examples{ 21 | route( 22 | c('GET', 'POST'), 23 | '^path$', 24 | function(req) { 25 | response() 26 | } 27 | ) 28 | 29 | route( 30 | 'put', 31 | '^another/path$', 32 | function(req) { 33 | response() 34 | } 35 | ) 36 | } 37 | \seealso{ 38 | \code{\link{route}}, \code{\link{mockup}} 39 | } 40 | \keyword{internal} 41 | -------------------------------------------------------------------------------- /man/prairie.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prairie.R 3 | \docType{package} 4 | \name{prairie} 5 | \alias{prairie} 6 | \alias{prairie-package} 7 | \alias{prairie-package} 8 | \title{prairie: Get Web Applications Growing In R} 9 | \description{ 10 | A web framework for R, prairie is based on existing 11 | frameworks like Express (JS), Django (python), Wookie (lisp), and 12 | Sinatra (ruby) and provides R users with a set of tools to create 13 | web applications from scratch. Alternatively, users can coerce and 14 | combine existing R code and custom classes into responses, routes, 15 | and applications to serve code and data across the web. 16 | } 17 | \seealso{ 18 | \code{\link{app}}, \code{\link{route}}, \code{\link{request}}, and 19 | \code{\link{response}} 20 | } 21 | \author{ 22 | \strong{Maintainer}: Nathan Teetor \email{nathanteetor@gmail.com} 23 | 24 | } 25 | -------------------------------------------------------------------------------- /man/as.request.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request.R 3 | \name{as.request} 4 | \alias{as.request} 5 | \alias{as.request.environment} 6 | \title{Coerce Rook Environments to Requests} 7 | \usage{ 8 | as.request(x) 9 | 10 | \method{as.request}{environment}(x) 11 | } 12 | \arguments{ 13 | \item{x}{An \R object.} 14 | } 15 | \description{ 16 | Internally, this function is used to coerce the request environment objects 17 | \code{httpuv} passes to an application's \code{call} function. Request 18 | environment objects are coerced to objects. 19 | } 20 | \examples{ 21 | e <- new.env(parent = emptyenv()) 22 | 23 | e$REQUEST_METHOD <- 'GET' 24 | e$PATH_INFO <- '/file/download' 25 | e$HTTP_ACCEPT <- 'application/json' 26 | e$HTTP_CONTENT_LENGTH <- '0' 27 | 28 | req <- as.request(e) 29 | is.request(req) # TRUE 30 | 31 | method(req) 32 | uri(req) 33 | req[['Accept']] 34 | req[['Content-Length']] 35 | 36 | } 37 | \seealso{ 38 | \code{\link{request}} 39 | } 40 | \keyword{internal} 41 | -------------------------------------------------------------------------------- /man/method.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request-request-line.R 3 | \name{method} 4 | \alias{method} 5 | \title{Request Method} 6 | \usage{ 7 | method(x) 8 | } 9 | \arguments{ 10 | \item{x}{A request object.} 11 | } 12 | \description{ 13 | Get information about a request such as method type, the requested resource 14 | uri, the query component, or the requset HTTP protocol. 15 | } 16 | \examples{ 17 | 18 | methodical <- route( 19 | c('GET', 'POST'), 20 | '^', 21 | function(req) { 22 | res <- response() 23 | 24 | if (method(req) == 'GET') { 25 | # handle when method is GET 26 | body(res) <- 'I got ya' 27 | 28 | } else { 29 | body(res) <- 'Washingtong or Huffington?' 30 | 31 | } 32 | 33 | res 34 | } 35 | ) 36 | 37 | methodical_m <- mockup(methodical) 38 | 39 | res <- methodical_m('GET', '/') 40 | res 41 | 42 | res <- methodical_m('POST', '/') 43 | body(res) 44 | 45 | } 46 | \seealso{ 47 | Other HTTP request request-line: \code{\link{query}}, 48 | \code{\link{uri}} 49 | } 50 | -------------------------------------------------------------------------------- /man/simpleHtmlTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{simpleHtmlTable} 4 | \alias{simpleHtmlTable} 5 | \title{Generate a minimal HTML table from a data frame 6 | 7 | This internal function is used by as.response() 8 | to encode a data frame into its HTML representation. 9 | The encoding is intentionally very minimal. 10 | Richer encoding would require either a complicated 11 | function or importing a heavy-weight package.} 12 | \usage{ 13 | simpleHtmlTable(dfrm, class = NULL, id = NULL) 14 | } 15 | \arguments{ 16 | \item{dfrm}{a data frame} 17 | 18 | \item{class}{an optional CSS class for the table} 19 | 20 | \item{id}{an optional CSS ID for the table} 21 | } 22 | \value{ 23 | an HTML representation of a table (character) 24 | } 25 | \description{ 26 | Generate a minimal HTML table from a data frame 27 | 28 | This internal function is used by as.response() 29 | to encode a data frame into its HTML representation. 30 | The encoding is intentionally very minimal. 31 | Richer encoding would require either a complicated 32 | function or importing a heavy-weight package. 33 | } 34 | -------------------------------------------------------------------------------- /man/mockup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mockup.R 3 | \name{mockup} 4 | \alias{mockup} 5 | \title{Mockup a Route} 6 | \usage{ 7 | mockup(r) 8 | } 9 | \arguments{ 10 | \item{r}{A route object.} 11 | } 12 | \value{ 13 | A route mockup will return the response object returned by the route handler. 14 | However, if the method passed to the mockup is not handled by the route or if 15 | the path is not handled by the route a 404 response object with a description 16 | as the body is returned. 17 | } 18 | \description{ 19 | Creates a mockup of a route object. A mockup simulates what sort of response 20 | is generated by a route given a method, uri, and headers (optional). 21 | } 22 | \details{ 23 | Unfortunately, \code{httpuv} requires a least one header is specified. 24 | Therefore, \code{headers} defaults to and must have at least one field 25 | specified. 26 | } 27 | \examples{ 28 | mkup_logger <- mockup( 29 | route( 30 | 'GET', 31 | '^', 32 | function(req) { 33 | print(req) 34 | response() 35 | } 36 | ) 37 | ) 38 | 39 | mkup_logger('GET', '/yellow/brick/path') 40 | mkup_logger('GET', '/phonday', headers = list(Accepts = 'text/html')) 41 | } 42 | -------------------------------------------------------------------------------- /tests/testthat/test-application-object.R: -------------------------------------------------------------------------------- 1 | context('test application') 2 | 3 | test_that('is.application and app() no arguments', { 4 | expect_true(is.application(app())) 5 | expect_false(is.application(character(1))) 6 | expect_false(is.application(integer(1))) 7 | }) 8 | 9 | test_that('application constructor constructs properly', { 10 | expect_true( 11 | is.application( 12 | app( 13 | route('GET', '^$', function(req) NULL), 14 | route('PUT', '^/putt/putt', function(req) NULL) 15 | ) 16 | ) 17 | ) 18 | }) 19 | 20 | test_that('application coerces arguments to routes', { 21 | expect_true( 22 | is.application( 23 | app( 24 | as.route('sample-route.R', directory = '.'), 25 | list( 26 | method = 'GET', 27 | path = '^', 28 | handler = function(req) NULL 29 | ) 30 | ) 31 | ) 32 | ) 33 | expect_error(app(3030)) 34 | }) 35 | 36 | test_that('starting application fails for incorrect args', { 37 | expect_error(run(route(), 'deltron', 3030)) 38 | expect_error(run(app(), 30, 30)) 39 | expect_error(run(app(), 'del', 'tron')) 40 | }) 41 | 42 | # deltron 3030, handy because the name is a string and a number 43 | -------------------------------------------------------------------------------- /tests/testthat/test-request-object.R: -------------------------------------------------------------------------------- 1 | context('request object / as.request') 2 | 3 | template_request <- list2env( 4 | list( 5 | HTTP_ACCEPT = "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8", 6 | HTTP_ACCEPT_ENCODING = "gzip, deflate, sdch", 7 | HTTP_ACCEPT_LANGUAGE = "en-US,en;q=0.8", 8 | HTTP_CACHE_CONTROL = "max-age=0", 9 | HTTP_CONTENT_TYPE = 'text/html; charset=utf-8', 10 | HTTP_CONNECTION = "keep-alive", 11 | HTTP_HOST = "localhost:3030", 12 | REQUEST_METHOD = 'GET', 13 | SCRIPT_NAME = '', 14 | PATH_INFO = '/foo/bar', 15 | QUERY_STRING = '', 16 | SERVER_NAME = '127.0.0.1', 17 | SERVER_PORT = '3030', 18 | HTTP_HOST = '127.0.0.1:3030', 19 | rook.version = 'nope', 20 | rook.url_scheme = 'https', 21 | rook.input = list( 22 | read_lines = function() '

Hello, world!

' 23 | ), 24 | rook.errors = 'Should I care?' 25 | ) 26 | ) 27 | 28 | test_that('request initialize with defaults', { 29 | req <- as.request(template_request) 30 | 31 | expect_equal(req$uri, '/foo/bar') 32 | expect_equal(req$body, '

Hello, world!

') 33 | expect_equal(req$headers$`Accept-Language`, 'en-US,en;q=0.8') 34 | expect_equal(req$query, '') 35 | }) 36 | 37 | -------------------------------------------------------------------------------- /man/request-headers.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request-header.R 3 | \name{request-headers} 4 | \alias{request-headers} 5 | \alias{[.request} 6 | \title{Request Header Fields} 7 | \usage{ 8 | \method{[}{request}(x, field) 9 | } 10 | \arguments{ 11 | \item{x}{A \code{request} object.} 12 | 13 | \item{field}{An HTTP request header field name.} 14 | } 15 | \description{ 16 | To get the values of request header fields \code{[} may be used to get a 17 | single or multiple values respectively. Request field names are 18 | case-sensitive. 19 | } 20 | \details{ 21 | For more information regarding HTTP request header fields please refer to 22 | \url{https://tools.ietf.org/html/rfc2616#section-5.3}. 23 | } 24 | \examples{ 25 | req <- request() 26 | 27 | req['Accept'] # NULL 28 | req['From'] # NULL, boring 29 | 30 | mkup_checkin <- mockup( 31 | route( 32 | 'POST', 33 | '^$', 34 | function(req) { 35 | print(req[['Accept']]) 36 | print(req[['From']]) 37 | 38 | response() 39 | } 40 | ) 41 | ) 42 | 43 | # More interesting output 44 | mkup_checkin( 45 | 'POST', 46 | '/', 47 | headers = list( 48 | Accept = 'text/html', 49 | From = 'Russia w/ Love' 50 | ) 51 | ) 52 | 53 | } 54 | -------------------------------------------------------------------------------- /tests/testthat/test-jsonify.R: -------------------------------------------------------------------------------- 1 | context('jsonify objects') 2 | 3 | test_that('arguments passed to `as.json` pass to `toJSON`', { 4 | skip_if_not_installed('jsonlite') 5 | father_time <- Sys.time() 6 | frame_data <- data.frame(top = c(1:5), bottom = c(10:6), time = rep(father_time, 5)) 7 | expect_equal(jsonlite::toJSON(frame_data), as.json(frame_data)) 8 | expect_equal(jsonlite::toJSON(frame_data, dataframe = 'rows'), as.json(frame_data, dataframe = 'rows')) 9 | 10 | frame_list <- list(one = father_time, two = c('blue', 'red', 'blue')) 11 | expect_equal(jsonlite::toJSON(frame_list, Date = 'epoch'), as.json(frame_list, Date = 'epoch')) 12 | }) 13 | 14 | test_that('response object content-type is set to application/json if json', { 15 | skip_if_not_installed('jsonlite') 16 | res <- response() 17 | body(res) <- as.json(data.frame(one = 'fish', two = 'fish')) 18 | expect_true(is.json(body(res))) 19 | expect_true(is.character(body(res))) 20 | expect_false(is.data.frame(body(res))) 21 | expect_true(is.response(res)) 22 | expect_equal(res[['Content-Type']], 'application/json') 23 | 24 | }) 25 | 26 | test_that('request object content-type is set to application/json if json', { 27 | skip('needs reconsidering') 28 | skip_if_not_installed('jsonlite') 29 | }) 30 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",response) 4 | S3method("[<-",response) 5 | S3method(as.json,data.frame) 6 | S3method(as.json,list) 7 | S3method(as.list,response) 8 | S3method(as.request,environment) 9 | S3method(as.response,character) 10 | S3method(as.response,data.frame) 11 | S3method(as.response,matrix) 12 | S3method(as.route,character) 13 | S3method(as.route,list) 14 | S3method(as.route,route) 15 | S3method(format,application) 16 | S3method(format,request) 17 | S3method(format,response) 18 | S3method(format,route) 19 | S3method(print,application) 20 | S3method(print,request) 21 | S3method(print,response) 22 | S3method(print,route) 23 | export("body<-") 24 | export("status<-") 25 | export(app) 26 | export(application) 27 | export(as.json) 28 | export(as.request) 29 | export(as.response) 30 | export(as.route) 31 | export(body) 32 | export(is.application) 33 | export(is.json) 34 | export(is.request) 35 | export(is.response) 36 | export(is.route) 37 | export(method) 38 | export(mockup) 39 | export(query) 40 | export(reason_phrase) 41 | export(request) 42 | export(response) 43 | export(route) 44 | export(run) 45 | export(status) 46 | export(uri) 47 | import(htmltools) 48 | importFrom(httpuv,encodeURI) 49 | importFrom(httpuv,runServer) 50 | importFrom(stringr,str_match_all) 51 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: prairie 2 | Type: Package 3 | Title: Get Web Applications Growing In R 4 | Version: 0.0.1.3 5 | Authors@R: person("Nathan", "Teetor", email = "nathanteetor@gmail.com", role = c("cre", "aut")) 6 | Description: A web framework for R, prairie is based on existing 7 | frameworks like Express (JS), Django (python), Wookie (lisp), and 8 | Sinatra (ruby) and provides R users with a set of tools to create 9 | web applications from scratch. Alternatively, users can coerce and 10 | combine existing R code and custom classes into responses, routes, 11 | and applications to serve code and data across the web. 12 | License: MIT + file LICENSE 13 | URL: https://github.com/nteetor/prairie 14 | BugReports: https://github.com/nteetor/prairie/issues 15 | RoxygenNote: 6.0.1 16 | Depends: 17 | R (>= 3.0.0) 18 | Imports: 19 | htmltools, 20 | httpuv (>= 1.3.3), 21 | mime, 22 | stringr 23 | Suggests: 24 | jsonlite, 25 | testthat 26 | Collate: 27 | 'prairie.R' 28 | 'utils.R' 29 | 'request.R' 30 | 'request-request-line.R' 31 | 'request-header.R' 32 | 'response.R' 33 | 'response-header.R' 34 | 'response-utils.R' 35 | 'route.R' 36 | 'application.R' 37 | 'jsonify.R' 38 | 'status.R' 39 | 'body.R' 40 | 'mockup.R' 41 | 'zzz.R' 42 | -------------------------------------------------------------------------------- /man/response-headers.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/response-header.R 3 | \name{response-headers} 4 | \alias{response-headers} 5 | \alias{[.response} 6 | \alias{[<-.response} 7 | \title{HTTP Response Header Fields} 8 | \usage{ 9 | \method{[}{response}(x, field) 10 | 11 | \method{[}{response}(x, field) <- value 12 | } 13 | \arguments{ 14 | \item{x}{A response object.} 15 | 16 | \item{field}{An HTTP response header field name.} 17 | } 18 | \value{ 19 | A list of corresponding header field values. If the response does not contain 20 | a certain field then \code{NULL} is returned. 21 | } 22 | \description{ 23 | Within prairie, getting and setting the fields of the \code{\link{response}} 24 | header is much like assigning values to lists. One can use \code{[} to 25 | extract one or more fields or replace a single field. 26 | } 27 | \details{ 28 | For more information regarding specific HTTP response header fields refer to 29 | \url{http://www.w3.org/Protocols/rfc2616/rfc2616-sec6.html}. 30 | } 31 | \examples{ 32 | # create new response 33 | res <- response() 34 | 35 | # add single field to header 36 | res["Connection"] <- "keep-alive" 37 | 38 | # add multiple fields at once 39 | res[] <- list( 40 | Date = Sys.time(), 41 | Server = 'R/prairie' 42 | ) 43 | 44 | res 45 | 46 | } 47 | -------------------------------------------------------------------------------- /man/body.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/body.R 3 | \name{body} 4 | \alias{body} 5 | \alias{body<-} 6 | \title{HTTP Message Body} 7 | \usage{ 8 | body(x) 9 | 10 | body(x) <- value 11 | } 12 | \arguments{ 13 | \item{x}{An \R object.} 14 | 15 | \item{value}{The response body, if JSON the \code{Content-Type} is set to 16 | \code{application/json}.} 17 | } 18 | \value{ 19 | \code{body} resturns a character string if the request or response contains a 20 | message body, otherwise \code{NULL}. 21 | 22 | \code{body<-} invisibly returns the response. 23 | } 24 | \description{ 25 | Get the message body of a request or response or set the body of a response. 26 | } 27 | \details{ 28 | For more information about HTTP requests please refer to the 29 | \href{http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html}{Request} section 30 | of www.w3.org. 31 | } 32 | \examples{ 33 | transmog <- route( 34 | 'POST', 35 | '^transmogrify/json$', 36 | function(req) { 37 | res <- response() 38 | 39 | # get body of request 40 | raw_body <- body(req) 41 | data <- jsonlite::fromJSON(raw_body) 42 | 43 | mogrified <- lapply( 44 | data, 45 | function(col) paste0(as.character(col), '!!!') 46 | ) 47 | 48 | status(res) <- 200 49 | body(res) <- as.json(mogrified) 50 | 51 | res 52 | } 53 | ) 54 | } 55 | -------------------------------------------------------------------------------- /man/uri.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request-request-line.R 3 | \name{uri} 4 | \alias{uri} 5 | \title{Request URI} 6 | \usage{ 7 | uri(x) 8 | } 9 | \arguments{ 10 | \item{x}{A request object.} 11 | } 12 | \description{ 13 | Get a request's uri. 14 | } 15 | \examples{ 16 | 17 | mkup_name <- mockup( 18 | route( 19 | 'GET', 20 | '^/wizard/[a-z]+$', 21 | function(req) { 22 | res <- response() 23 | 24 | # An alternative to passing information 25 | # as a request query 26 | wizard_name <- gsub('^/wizard/', '', uri(req)) 27 | 28 | picker <- list( 29 | title = c('The', 'Dark Lord', 'Sir'), 30 | name = wizard_name, 31 | of = 'of the', 32 | adjective = c('Enduring', 'Swift', 'Red', 'Great'), 33 | noun = c('Heavens', 'Coldness', 'Winglelings', 'Stars') 34 | ) 35 | 36 | body(res) <- paste( 37 | lapply(picker, function(n) n[sample(length(n), 1)]), 38 | collapse = ' ' 39 | ) 40 | 41 | res 42 | } 43 | ) 44 | ) 45 | 46 | res <- mkup_name('GET', '/wizard/jenkins') 47 | body(res) 48 | 49 | res <- mkup_name('GET', '/wizard/merlin') 50 | body(res) 51 | 52 | res <- mkup_name('GET', '/wizard/sparrowhawk') 53 | body(res) 54 | 55 | } 56 | \seealso{ 57 | Other HTTP request request-line: \code{\link{method}}, 58 | \code{\link{query}} 59 | } 60 | -------------------------------------------------------------------------------- /tests/testthat/test-route-functions.R: -------------------------------------------------------------------------------- 1 | context('route functions') 2 | 3 | test_that('is.route returns TRUE/FALSE appropriately', { 4 | expect_true(is.route(route('', '', function(req) NULL))) 5 | expect_false(is.route('route')) 6 | expect_false(is.route(c('route', '31'))) 7 | expect_false(is.route(3030)) 8 | expect_false(is.route(data.frame())) 9 | }) 10 | 11 | test_that('as.route.route coerces correctly', { 12 | route31 <- route('', '', function(req) NULL) 13 | expect_true(is.route(route31)) 14 | expect_true(is.route(as.route(route31))) 15 | }) 16 | 17 | test_that('as.route.character coerces correctly', { 18 | expect_true(is.route(as.route('sample-route.R', directory = '.'))) 19 | expect_error(as.route('does-not-exist-route.R', directory = '.')) 20 | expect_error(as.route('whoops-route.R', directory = '.'), '^Error : Could not parse') 21 | }) 22 | 23 | test_that('as.route.list coerces correctly', { 24 | expect_true(is.route(as.route(list(method = '', path = '', handler = function(req) NULL)))) 25 | expect_error(as.route(list(path = '', handler = function(req) NULL))) 26 | expect_error(as.route(list())) 27 | }) 28 | 29 | test_that('print function', { 30 | sesame_route <- route('PUT', 'down/the/ducky', function(req) response()) 31 | route_output <- paste(capture.output(print(sesame_route)), collapse = '') 32 | expect_equal(route_output, 'route put down/the/ducky') 33 | }) 34 | -------------------------------------------------------------------------------- /R/request-header.R: -------------------------------------------------------------------------------- 1 | #' Request Header Fields 2 | #' 3 | #' To get the values of request header fields \code{[} may be used to get a 4 | #' single or multiple values respectively. Request field names are 5 | #' case-sensitive. 6 | #' 7 | #' @param x A \code{request} object. 8 | #' @param field An HTTP request header field name. 9 | #' 10 | #' @details 11 | #' 12 | #' For more information regarding HTTP request header fields please refer to 13 | #' \url{https://tools.ietf.org/html/rfc2616#section-5.3}. 14 | #' 15 | #' @name request-headers 16 | #' @examples 17 | #' req <- request() 18 | #' 19 | #' req['Accept'] # NULL 20 | #' req['From'] # NULL, boring 21 | #' 22 | #' mkup_checkin <- mockup( 23 | #' route( 24 | #' 'POST', 25 | #' '^$', 26 | #' function(req) { 27 | #' print(req[['Accept']]) 28 | #' print(req[['From']]) 29 | #' 30 | #' response() 31 | #' } 32 | #' ) 33 | #' ) 34 | #' 35 | #' # More interesting output 36 | #' mkup_checkin( 37 | #' 'POST', 38 | #' '/', 39 | #' headers = list( 40 | #' Accept = 'text/html', 41 | #' From = 'Russia w/ Love' 42 | #' ) 43 | #' ) 44 | #' 45 | `[.request` <- function(x, field) { 46 | if (!is.character(field)) { 47 | stop('argument `field` must be of class character', call. = FALSE) 48 | } 49 | 50 | if (length(field) != 1) { 51 | stop('argument `field` must be a character string', call. = FALSE) 52 | } 53 | 54 | if (field %in% c('Referer', 'Referrer')) { 55 | x[['headers']][['Referer']] %||% x[['headers']][['Referrer']] 56 | } else { 57 | x[['headers']][[field]] 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /man/json.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/jsonify.R 3 | \name{json} 4 | \alias{json} 5 | \alias{is.json} 6 | \alias{as.json} 7 | \alias{as.json.list} 8 | \alias{as.json.data.frame} 9 | \title{Convert Objects to JSON} 10 | \usage{ 11 | is.json(x) 12 | 13 | as.json(x, ...) 14 | 15 | \method{as.json}{list}(x, ...) 16 | 17 | \method{as.json}{data.frame}(x, ...) 18 | } 19 | \arguments{ 20 | \item{x}{Any \R object.} 21 | 22 | \item{\ldots}{Additional arguments to pass on to \code{jsonlite::toJSON}.} 23 | } 24 | \description{ 25 | When building a web server or API it is often useful to send more complex 26 | data obects. Within prairie one can do this by converting the object to JSON. 27 | Additionally, prairie exposes the generic \code{as.json} function allowing 28 | users to specify how their custom classes need to be converted to JSON. 29 | } 30 | \details{ 31 | For the included \code{as.json} functions, the excellent package 32 | \code{jsonlite} does all the heavy lifting behind the scenes. This package is 33 | straightforward to use and is recommended for those who wish to create 34 | further \code{as.json} functions. 35 | 36 | Setting a response object body as an object with class json will 37 | automatically set the response object's Content-Type to application/json. 38 | } 39 | \examples{ 40 | as.json(list(one = 'fish', two = 'fish')) 41 | as.json(data.frame(red = 'fish', blue = 'fish')) 42 | 43 | res <- response() 44 | body(res) <- as.json( 45 | list( 46 | list(name = 'ged', job = 'wizard'), 47 | list(name = 'sparrowhawk', job = 'wizard') 48 | ) 49 | ) 50 | 51 | is.json(body(res)) 52 | res[['Content-Type']] == 'application/json' 53 | 54 | } 55 | -------------------------------------------------------------------------------- /R/body.R: -------------------------------------------------------------------------------- 1 | #' HTTP Message Body 2 | #' 3 | #' Get the message body of a request or response or set the body of a response. 4 | #' 5 | #' @param x An \R object. 6 | #' @param value The response body, if JSON the \code{Content-Type} is set to 7 | #' \code{application/json}. 8 | #' 9 | #' @details 10 | #' 11 | #' For more information about HTTP requests please refer to the 12 | #' \href{http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html}{Request} section 13 | #' of www.w3.org. 14 | #' 15 | #' @return 16 | #' 17 | #' \code{body} resturns a character string if the request or response contains a 18 | #' message body, otherwise \code{NULL}. 19 | #' 20 | #' \code{body<-} invisibly returns the response. 21 | #' 22 | #' @export 23 | #' @examples 24 | #' transmog <- route( 25 | #' 'POST', 26 | #' '^transmogrify/json$', 27 | #' function(req) { 28 | #' res <- response() 29 | #' 30 | #' # get body of request 31 | #' raw_body <- body(req) 32 | #' data <- jsonlite::fromJSON(raw_body) 33 | #' 34 | #' mogrified <- lapply( 35 | #' data, 36 | #' function(col) paste0(as.character(col), '!!!') 37 | #' ) 38 | #' 39 | #' status(res) <- 200 40 | #' body(res) <- as.json(mogrified) 41 | #' 42 | #' res 43 | #' } 44 | #' ) 45 | body <- function(x) { 46 | if (!(is.request(x) || is.response(x))) { 47 | stop('cannot get body of a ', class(x), call. = FALSE) 48 | } 49 | unclass(x)[['body']] 50 | } 51 | 52 | #' @rdname body 53 | #' @export 54 | `body<-` <- function(x, value) { 55 | if (!is.response(x)) { 56 | stop('cannot set the body of a ', class(x), call. = FALSE) 57 | } 58 | 59 | orig <- class(x) 60 | x <- unclass(x) 61 | 62 | x[['body']] <- value 63 | 64 | if (is.json(value)) { 65 | x[['headers']][['Content-Type']] <- 'application/json' 66 | } 67 | 68 | class(x) <- orig 69 | 70 | invisible(x) 71 | } 72 | -------------------------------------------------------------------------------- /man/application.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/application.R 3 | \name{application} 4 | \alias{application} 5 | \alias{app} 6 | \alias{is.application} 7 | \title{Create an Application} 8 | \usage{ 9 | application(...) 10 | 11 | app(...) 12 | 13 | is.application(x) 14 | } 15 | \arguments{ 16 | \item{\ldots}{\R objects, coerced to routes.} 17 | } 18 | \description{ 19 | A prairie application, simply put, is a list of route objects. When creating 20 | an application, \code{\ldots} may be any combination of \R objects with a 21 | \code{as.route} implementation, see details. 22 | } 23 | \details{ 24 | In order for prairie to best help \R programmers grow web applications from 25 | their existing code many coercion generics have been created and are 26 | available for implementation. The, arguably, most important of generic is 27 | \code{as.route}. CRAN is ripe with packages which include custom S3 classes. 28 | prairie aims to provide a streamlined process for serving these classes 29 | across the web. An implementation of \code{as.route} might choose a resouce 30 | path based on a class attribute or choose the HTTP method based on object 31 | permissions (GET for a read-only database connection or GET and POST for a 32 | read/write connection). 33 | 34 | Furthmore, prairie is meant to work on top of, around, and with existing \R 35 | code. While writing a good implementation of \code{as.route} may take time, 36 | if this package is succesful, one will not need to modify existing code. You 37 | have worked hard on your code and prairie is along to grow that code onwards 38 | to the web. 39 | } 40 | \examples{ 41 | app( 42 | route( 43 | 'GET', 44 | '^', 45 | function(req) { 46 | res <- response() 47 | body(res) <- 'Hello, world!' 48 | res 49 | } 50 | ) 51 | ) 52 | 53 | } 54 | \seealso{ 55 | \code{\link{as.route}}, \code{\link{run}} 56 | } 57 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | context('util functions') 2 | 3 | test_that('`%||%` function', { 4 | expect_true(is.function(`%||%`)) 5 | expect_equal(3030, NULL %||% 3030) 6 | }) 7 | 8 | test_that('http_date function', { 9 | date1 <- strptime('11/06/1994 08:49:37', '%m/%d/%Y %H:%M:%S', tz = 'UTC') 10 | expect_equal('Sun, 06 Nov 1994 08:49:37 UTC', http_date(date1)) 11 | 12 | date2 <- strptime('12/04/2015', '%m/%d/%Y', tz = 'UTC') 13 | expect_equal('Fri, 04 Dec 2015 00:00:00 UTC', http_date(date2)) 14 | 15 | expect_error(http_date('01/01/3030')) 16 | expect_error(http_date(3030)) 17 | }) 18 | 19 | test_that('is_named function', { 20 | expect_false(is_named('voldemort')) 21 | expect_false(is_named(9.75)) 22 | dark_lord <- 'voldemort' 23 | names(dark_lord) <- 'he who must not be named' 24 | expect_true(is_named(dark_lord)) 25 | 26 | expect_true(is_named(list(one = 'fish', two = 'fish'))) 27 | expect_false(is_named(list())) 28 | expect_false(is_named(list('tombs', of = 'atuan'))) 29 | expect_false(is_named(list('deltron', 3030))) 30 | 31 | expect_true(is_named(c(little = 'bunny', foo = 'foo'))) 32 | expect_false(is_named(1:5)) 33 | }) 34 | 35 | test_that('is_absolute function', { 36 | expect_false(is_absolute('edward')) 37 | expect_error(is_absolute(36)) 38 | 39 | expect_true(is_absolute('/yellow/brick/road')) 40 | expect_false(is_absolute('../we/re/in/kansas')) 41 | 42 | expect_true(is_absolute('C:\\is\\for\\cookie')) 43 | expect_true(is_absolute('\\\\tires\\tires\\not\\really')) 44 | }) 45 | 46 | test_that('zfill and bfill functions', { 47 | expect_equal(zfill(5), '00000') 48 | expect_equal(zfill(3, '|'), '|||') 49 | expect_equal(bfill(2), ' ') 50 | expect_equal(bfill(6), ' ') 51 | }) 52 | 53 | test_that('status reason_phrase function', { 54 | expect_error(reason_phrase(TRUE), 'is.numeric(status_code) || is.character(status_code)') 55 | expect_equal(reason_phrase(100), 'Continue') 56 | expect_equal(reason_phrase(404), 'Not Found') 57 | expect_equal(reason_phrase(515), '') 58 | }) 59 | -------------------------------------------------------------------------------- /R/jsonify.R: -------------------------------------------------------------------------------- 1 | #' Convert Objects to JSON 2 | #' 3 | #' When building a web server or API it is often useful to send more complex 4 | #' data obects. Within prairie one can do this by converting the object to JSON. 5 | #' Additionally, prairie exposes the generic \code{as.json} function allowing 6 | #' users to specify how their custom classes need to be converted to JSON. 7 | #' 8 | #' @details 9 | #' 10 | #' For the included \code{as.json} functions, the excellent package 11 | #' \code{jsonlite} does all the heavy lifting behind the scenes. This package is 12 | #' straightforward to use and is recommended for those who wish to create 13 | #' further \code{as.json} functions. 14 | #' 15 | #' Setting a response object body as an object with class json will 16 | #' automatically set the response object's Content-Type to application/json. 17 | #' 18 | #' @name json 19 | #' @examples 20 | #' as.json(list(one = 'fish', two = 'fish')) 21 | #' as.json(data.frame(red = 'fish', blue = 'fish')) 22 | #' 23 | #' res <- response() 24 | #' body(res) <- as.json( 25 | #' list( 26 | #' list(name = 'ged', job = 'wizard'), 27 | #' list(name = 'sparrowhawk', job = 'wizard') 28 | #' ) 29 | #' ) 30 | #' 31 | #' is.json(body(res)) 32 | #' res[['Content-Type']] == 'application/json' 33 | #' 34 | NULL 35 | 36 | #' @param x Any \R object. 37 | #' @export 38 | #' @rdname json 39 | is.json <- function(x) inherits(x, 'json') 40 | 41 | #' @param \ldots Additional arguments to pass on to \code{jsonlite::toJSON}. 42 | #' @export 43 | #' @rdname json 44 | as.json <- function(x, ...) UseMethod('as.json') 45 | 46 | #' @export 47 | #' @rdname json 48 | as.json.list <- function(x, ...) { 49 | if (!requireNamespace('jsonlite', quietly = TRUE)) { 50 | stop('package "jsonlite" must be installed', call. = FALSE) 51 | } 52 | jsonlite::toJSON(x, ...) 53 | } 54 | 55 | #' @export 56 | #' @rdname json 57 | as.json.data.frame <- function(x, ...) { 58 | if (!requireNamespace('jsonlite', quietly = TRUE)) { 59 | stop('package "jsonlite" must be installed', call. = FALSE) 60 | } 61 | jsonlite::toJSON(x, ...) 62 | } 63 | -------------------------------------------------------------------------------- /man/as.route.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/route.R 3 | \name{as.route} 4 | \alias{as.route} 5 | \alias{as.route.route} 6 | \alias{as.route.character} 7 | \alias{as.route.list} 8 | \title{Coercing Objects to Routes} 9 | \usage{ 10 | as.route(x, ...) 11 | 12 | \method{as.route}{route}(x, ...) 13 | 14 | \method{as.route}{character}(x, directory = "routes", ...) 15 | 16 | \method{as.route}{list}(x, ...) 17 | } 18 | \arguments{ 19 | \item{x}{An \R object.} 20 | 21 | \item{directory}{System path to the folder containing the route file.} 22 | 23 | \item{\ldots}{Additional arguments passed on to methods.} 24 | } 25 | \value{ 26 | A \code{route} object. 27 | } 28 | \description{ 29 | The function \code{as.route} provides an alternative means of creating an 30 | application route. 31 | } 32 | \details{ 33 | If \code{x} is a list, \code{x} must have the following named elements: 34 | \code{method}, \code{path}, and \code{handler}. 35 | 36 | If \code{x} is a character vector, \code{x} is interpreted as a file name. 37 | The file must contain a route defined using the \code{route} function. The 38 | default directory for route files is "routes", but a different folder may be 39 | specified with the \code{directory} argument. 40 | 41 | The S3 generic function \code{as.route} is exported by prairie to encourage 42 | creation of \code{as.route.*} functions. Custom \code{as.route} functions 43 | allow users to coerce their classes to routes and quickly serve them over 44 | HTTP. 45 | } 46 | \examples{ 47 | # Easily reuse routes and keep applications 48 | # modular by storing routes in separate files. 49 | 50 | tmp <- tempfile() 51 | writeLines( 52 | 'route("GET", "^$", function(req) response())\\n', 53 | con = tmp 54 | ) 55 | 56 | as.route(tmp, dir = '') 57 | 58 | file.remove(tmp) 59 | 60 | # as.route.list is a minimal wrapper 61 | # around route() 62 | 63 | route( 64 | 'POST', 65 | '^$', 66 | function(req) { 67 | response() 68 | } 69 | ) 70 | 71 | as.route( 72 | list( 73 | method = 'POST', 74 | path = '^$', 75 | handler = function(req) { 76 | response() 77 | } 78 | ) 79 | ) 80 | } 81 | \seealso{ 82 | \code{\link{route}} 83 | } 84 | -------------------------------------------------------------------------------- /R/response-header.R: -------------------------------------------------------------------------------- 1 | #' HTTP Response Header Fields 2 | #' 3 | #' Within prairie, getting and setting the fields of the \code{\link{response}} 4 | #' header is much like assigning values to lists. One can use \code{[} to 5 | #' extract one or more fields or replace a single field. 6 | #' 7 | #' @param x A response object. 8 | #' @param field An HTTP response header field name. 9 | #' 10 | #' @details 11 | #' 12 | #' For more information regarding specific HTTP response header fields refer to 13 | #' \url{http://www.w3.org/Protocols/rfc2616/rfc2616-sec6.html}. 14 | #' 15 | #' @return 16 | #' 17 | #' A list of corresponding header field values. If the response does not contain 18 | #' a certain field then \code{NULL} is returned. 19 | #' 20 | #' @name response-headers 21 | #' @export 22 | #' @examples 23 | #' # create new response 24 | #' res <- response() 25 | #' 26 | #' # add single field to header 27 | #' res["Connection"] <- "keep-alive" 28 | #' 29 | #' # add multiple fields at once 30 | #' res[] <- list( 31 | #' Date = Sys.time(), 32 | #' Server = 'R/prairie' 33 | #' ) 34 | #' 35 | #' res 36 | #' 37 | `[.response` <- function(x, field) { 38 | if (!is.character(field)) { 39 | stop('argument `field` must be of class character', call. = FALSE) 40 | } 41 | 42 | if (length(field) != 1) { 43 | stop('argument `field` must be a single character string', call. = FALSE) 44 | } 45 | 46 | x[['headers']][[field]] 47 | } 48 | 49 | #' @rdname response-headers 50 | #' @export 51 | `[<-.response` <- function(x, field, value) { 52 | if (missing(field)) { 53 | if (!is_named(value)) { 54 | stop('argument `value` must be named', call. = FALSE) 55 | } 56 | 57 | x[['headers']] <- value 58 | 59 | } else { 60 | if (!is.character(field)) { 61 | stop('argument `field` must be of class character', call. = FALSE) 62 | } 63 | 64 | if (length(field) != 1) { 65 | stop('argument `field` must be a character string', call. = FALSE) 66 | } 67 | 68 | # @TODO I'm not sold one way or another on this 69 | # if (inherits(x, 'Date') || inherits(x, 'POSIXt')) { 70 | # value <- http_date(value) 71 | # } 72 | 73 | x[['headers']][[field]] <- value 74 | } 75 | 76 | invisible(x) 77 | } 78 | -------------------------------------------------------------------------------- /man/response.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/response.R 3 | \name{response} 4 | \alias{response} 5 | \title{Create an HTTP Response} 6 | \usage{ 7 | response(status = 200, content_type = "text/plain", body = "") 8 | } 9 | \arguments{ 10 | \item{status}{(numeric) HTTP status code, e.g. 200 for OK, 404 for Not Found} 11 | 12 | \item{content_type}{(character) MIME content type, e.g., "text/plain", "text/html".} 13 | 14 | \item{body}{(character) Body of the response} 15 | } 16 | \description{ 17 | A response object represents the HTTP response returned by a route handler. A 18 | response is typically made up of a status, HTTP headers, and a body. A 19 | response body is optional. 20 | } 21 | \section{Components}{ 22 | 23 | 24 | \subsection{status:}{ 25 | 26 | Set the status of a response to indicate what action, if any, the client 27 | needs to take. Otherwise a status of 2XX indicates a client request was 28 | valid and the response object contains the requested resource. 29 | 30 | Below are descriptions for each status code class, 31 | 32 | \describe{ 33 | 34 | \item{1xx:}{Informational - Request received, continuing process} 35 | 36 | \item{2xx:}{Success - The action was successfully received, understood, and 37 | accepted} 38 | 39 | \item{3xx:}{Redirection - Further action must be taken in order to complete 40 | the request} 41 | 42 | \item{4xx:}{Client Error - The request contains bad syntax or cannot be 43 | fulfilled} 44 | 45 | \item{5xx:}{Server Error - The server failed to fulfill an apparently valid 46 | request} 47 | 48 | } 49 | 50 | } 51 | 52 | \subsection{headers:}{ 53 | 54 | stub 55 | 56 | } 57 | 58 | \subsection{body:}{ 59 | 60 | stub 61 | 62 | } 63 | } 64 | 65 | \examples{ 66 | # a route to return a client-requested status 67 | # and reason phrase 68 | mkup <- mockup( 69 | route( 70 | 'GET', 71 | '^\\\\d+', 72 | function(req) { 73 | stts <- sub('/', '', uri(req)) 74 | 75 | res <- response() 76 | 77 | status(res) <- 200 78 | body(res) <- paste(stts, reason_phrase(stts)) 79 | 80 | res 81 | } 82 | ) 83 | ) 84 | 85 | mkup('get', '302') 86 | mkup('get', '203') 87 | 88 | } 89 | \seealso{ 90 | \code{\link{route}}, \code{\link{request}} 91 | } 92 | -------------------------------------------------------------------------------- /man/as.response.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/response.R 3 | \name{as.response} 4 | \alias{as.response} 5 | \alias{as.response.character} 6 | \alias{as.response.data.frame} 7 | \alias{as.response.matrix} 8 | \alias{is.response} 9 | \title{Coerce Objects to Responses} 10 | \usage{ 11 | as.response(x, ...) 12 | 13 | \method{as.response}{character}(x, directory = "views", collapse = "\\n", 14 | ...) 15 | 16 | \method{as.response}{data.frame}(x, format = "json", ...) 17 | 18 | \method{as.response}{matrix}(x, ...) 19 | 20 | is.response(x) 21 | } 22 | \arguments{ 23 | \item{x}{Any \R object.} 24 | 25 | \item{directory}{A character string specifying the system folder of the file 26 | \code{x}.} 27 | 28 | \item{collapse}{A character string specifying how to collapse the lines read 29 | from \code{x}.} 30 | 31 | \item{format}{A character string, determining the form of the HTTP response. 32 | Can be one of \code{"csv"}, \code{"html"}, \code{"json"}, or \code{"text"}.} 33 | 34 | \item{\ldots}{Additional arguments passed on to methods.} 35 | } 36 | \description{ 37 | The \code{as.response} functions simplify serving up R objects as server 38 | responses. 39 | } 40 | \details{ 41 | \code{as.response.character} expects \code{x} is a character string 42 | specifying a file name. The default directory for the file is "views", but a 43 | different path may be specified with the \code{directory} argument. If the 44 | file exists the contents are read and set as the response body. The response 45 | Content-Type is guessed from the file extension using 46 | \code{\link[mime]{guess_type}}. 47 | 48 | \code{as.response.data.frame} coerces and serves up a data frame. 49 | Several response types are possible. 50 | \itemize{ 51 | \item CSV (text/csv) - Same format as \link{write.csv}, without row names. 52 | \item HTML (text/html) - Formatted by \link{simpleHtmlTable}. 53 | Additional arguments may be passed to the formatter using \code{\ldots}. 54 | \item JSON (application/json) - The 55 | data frame is coerced using the \code{\link{as.json}} function and additional 56 | arguments may be passed to \code{as.json} using \code{\ldots}. 57 | \item Text (text/plain) - Simple text rendering. 58 | } 59 | } 60 | \examples{ 61 | 62 | is.response(logical(1)) 63 | is.response(response()) 64 | is.response(3030) 65 | } 66 | -------------------------------------------------------------------------------- /man/request.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/request.R 3 | \name{request} 4 | \alias{request} 5 | \alias{is.request} 6 | \title{Create an HTTP Request} 7 | \usage{ 8 | request() 9 | 10 | is.request(x) 11 | } 12 | \description{ 13 | Request objects store relevant information sent from the client to the server 14 | as a part of an HTTP request. Request objects are not typically explicitly 15 | created. Instead, a request object is passed as an argument to a route 16 | handler. 17 | } 18 | \details{ 19 | Request objects contain the following information. 20 | 21 | \subsection{method:}{ 22 | 23 | Most often \code{GET} or \code{POST}, the method indicates what action to 24 | take for a specified resource. This value may be accessed with 25 | \code{\link{method}}. 26 | 27 | } 28 | 29 | \subsection{uri:}{ 30 | 31 | The uri indicates the server resource requested by the client. A request 32 | object's uri may be accessed with \code{\link{uri}}. 33 | 34 | } 35 | 36 | \subsection{query:}{ 37 | 38 | A request query is set of key value pairs following the uri. A query is 39 | indicated by a ? and is, optionally, ended with a #. Query keys are case- 40 | sensitive. A request object's query list may be accessed with \link{query}. 41 | If an incoming request does not have a query string then \code{query} will 42 | return an empty list. 43 | 44 | } 45 | 46 | \subsection{headers:}{ 47 | 48 | Request header fields may be accessed by treating a request object like a 49 | list. Using [ or [[, one can get a single or multiple header field values. 50 | Header fields are case-insensitive. 51 | 52 | } 53 | 54 | \subsection{body:}{ 55 | 56 | The body message of a request object may be retreived with \link{body}. 57 | 58 | } 59 | } 60 | \examples{ 61 | # not much to see here 62 | req <- request() 63 | print(req) 64 | 65 | # the request object is loaded with information 66 | # from the client 67 | printreq <- route( 68 | 'GET', 69 | '^/print/request$', 70 | function(req) { 71 | print('Request received:') 72 | print(req) 73 | 74 | response() 75 | } 76 | ) 77 | 78 | # create mockup 79 | printreq_m <- mockup(printreq) 80 | 81 | # now there's something to see 82 | printreq_m('get', '/print/request') 83 | printreq_m('get', '/print/request', 84 | headers = list( 85 | Accept = 'text/html', 86 | Host = 'with the most' 87 | ) 88 | ) 89 | } 90 | -------------------------------------------------------------------------------- /tests/testthat/test-request-functions.R: -------------------------------------------------------------------------------- 1 | context('request functions') 2 | 3 | template_request <- list2env( 4 | list( 5 | HTTP_ACCEPT = "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8", 6 | HTTP_ACCEPT_ENCODING = "gzip, deflate, sdch", 7 | HTTP_ACCEPT_LANGUAGE = "en-US,en;q=0.8", 8 | HTTP_CACHE_CONTROL = "max-age=0", 9 | HTTP_CONTENT_TYPE = 'text/html; charset=utf-8', 10 | HTTP_CONNECTION = "keep-alive", 11 | HTTP_HOST = "localhost:3030", 12 | HTTP_REFERER = 'http://www.references.com', 13 | REQUEST_METHOD = 'GET', 14 | SCRIPT_NAME = '', 15 | PATH_INFO = '/foo/bar', 16 | QUERY_STRING = 'key=value', 17 | SERVER_NAME = '127.0.0.1', 18 | SERVER_PORT = '3030', 19 | HTTP_HOST = '127.0.0.1:3030', 20 | rook.version = 'nope', 21 | rook.url_scheme = 'https', 22 | rook.input = list( 23 | read_lines = function() { 24 | '

Hello, world!

' 25 | } 26 | ), 27 | rook.errors = 'Should I care?' 28 | ) 29 | ) 30 | 31 | test_that('`[[` and `[` properly gets header fields', { 32 | req <- as.request(template_request) 33 | 34 | expect_equal(req[['Cache-Control']], 'max-age=0') 35 | expect_equal(req[['Connection']], 'keep-alive') 36 | expect_equal(req[['Accept-Encoding']], 'gzip, deflate, sdch') 37 | expect_null(req[['foo']]) 38 | expect_equal(req[c('Cache-Control', 'Connection')], list(`Cache-Control` = 'max-age=0', Connection = 'keep-alive')) 39 | }) 40 | 41 | test_that('[[\'Referer\']] and [[\'Referrer\']] are equivalent', { 42 | req <- as.request(template_request) 43 | 44 | expect_equal(req[['Referer']], req[['Referrer']]) 45 | expect_equal(req[['Referer']], 'http://www.references.com') 46 | }) 47 | 48 | test_that('url function', { 49 | expect_error(uri('request')) 50 | expect_error(uri(3030)) 51 | req <- as.request(template_request) 52 | expect_equal(uri(req), '/foo/bar') 53 | }) 54 | 55 | test_that('body function', { 56 | req <- as.request(template_request) 57 | expect_equal(body(req), '

Hello, world!

') 58 | }) 59 | 60 | test_that('method function', { 61 | req <- as.request(template_request) 62 | expect_equal(method(req), 'get') 63 | }) 64 | 65 | test_that('query function', { 66 | req <- as.request(template_request) 67 | expect_equal(query(req), 'key=value') 68 | }) 69 | 70 | test_that('print function', { 71 | req <- as.request(template_request) 72 | req_output <- paste(capture.output(print(req)), collapse = '') 73 | expect_equal(req_output, "get /foo/bar HTTP/1.1 \rReferer: http://www.references.com\rHost: 127.0.0.1:3030\rConnection: keep-alive\rContent-Type: text/html; charset=utf-8\rCache-Control: max-age=0\rAccept-Language: en-US,en;q=0.8\rAccept-Encoding: gzip, deflate, sdch\rAccept: text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8\r\r

Hello, world!

\r") 74 | }) 75 | -------------------------------------------------------------------------------- /tests/testthat/test-route-object.R: -------------------------------------------------------------------------------- 1 | context('route object') 2 | 3 | test_that('route stops on incorrect arguments', { 4 | expect_error(route(3030, '^test/$', function(req) response())) 5 | expect_error(route('get', 3030, function(req) response())) 6 | expect_error(route('get', '^test/$', 'WRONG')) 7 | }) 8 | 9 | test_that('route matching with different paths', { 10 | route_hello <- route('get', '^test$', function(req) response()) 11 | route_hello_m <- mockup(route_hello) 12 | 13 | expect_status <- function(s1, s2) { 14 | route_status <- status(s1) 15 | eval(bquote(expect_equal(.(route_status), .(s2)))) 16 | } 17 | 18 | expect_status(route_hello_m('get', 'hello/world/'), 404) 19 | expect_status(route_hello_m('get', 'unit/test'), 404) 20 | expect_status(route_hello_m('get', 'testing'), 404) 21 | 22 | expect_status(route_hello_m('get', 'test'), 200) 23 | }) 24 | 25 | test_that('route matching with different methods', { 26 | route_get <- route('get', '^.*', function(req) response()) 27 | route_get_m <- mockup(route_get) 28 | 29 | expect_status <- function(s1, s2) { 30 | route_status <- status(s1) 31 | eval(bquote(expect_equal(.(route_status), .(s2)))) 32 | } 33 | 34 | expect_status(route_get_m('put', 'path'), 404) 35 | expect_status(route_get_m('head', 'path'), 404) 36 | expect_status(route_get_m('post', 'path'), 404) 37 | 38 | expect_status(route_get_m('get', 'path'), 200) 39 | expect_status(route_get_m('get', 'another/path'), 200) 40 | expect_status(route_get_m('get', 'else'), 200) 41 | }) 42 | 43 | test_that('index route matches correct paths', { 44 | route_index <- route('get', '^$', function(req) response()) 45 | route_index_m <- mockup(route_index) 46 | 47 | expect_status <- function(s1, s2) { 48 | route_status <- status(s1) 49 | eval(bquote(expect_equal(.(route_status), .(s2)))) 50 | } 51 | 52 | expect_status(route_index_m('get', 'oops'), 404) 53 | 54 | expect_status(route_index_m('get', ''), 404) 55 | }) 56 | 57 | test_that('path may only be vector of length 1', { 58 | expect_error(route('get', c('red', 'fish', 'blue', 'fish'), function(req) respsonse())) 59 | expect_error(route('get', c('one', 'two'), function(req) response())) 60 | }) 61 | 62 | test_that('a single route catches matching requests', { 63 | skip('todo in the future') 64 | route_many <- route('get', c('^number|numeric|numeral$'), function(req) response()) 65 | 66 | # expect_true(route_many$matches('get', 'numeric')) 67 | # expect_true(route_many$matches('get', 'numeral')) 68 | }) 69 | 70 | test_that('uri named parameters are extracted', { 71 | skip('TODO') 72 | 73 | route_groups <- route('get', '^/(?\\w+)/(?\\d+)$', function(req) NULL) 74 | 75 | expect_equal(route_groups$params, c('name', 'age')) 76 | 77 | expect_error(route('get', '^/(?<>\\w+)', function(req) NULL), 'route URI contains empty') 78 | 79 | route_no_groups <- route('get', '^/foo/bar', function(req) NULL) 80 | 81 | expect_equal(route_no_groups$params, c()) 82 | }) 83 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | # borrowing from javascript, will return 2 | `%||%` <- function(a, b) if (is.null(a)) b else a 3 | 4 | mimeextra <- c( 5 | md = "text/markdown", 6 | markdown = "text/markdown", 7 | r = "text/plain", 8 | rd = "text/plain", 9 | rmd = "text/markdown", 10 | geojson = "application/vnd.geo+json", 11 | NULL 12 | ) 13 | 14 | is.date <- function(x) { 15 | inherits(x, 'Date') | inherits(x, 'POSIXt') 16 | } 17 | 18 | http_date <- function(x) { 19 | if (!(inherits(x, 'Date') || inherits(x, 'POSIXt'))) { 20 | stop('argument `x` must be of class Date or POSIXt', call. = FALSE) 21 | } 22 | strftime(x, format = '%a, %d %b %Y %H:%M:%S', usetz = TRUE) 23 | } 24 | 25 | collapse <- function(..., sep = ', ') { 26 | paste(..., sep = sep, collapse = sep) 27 | } 28 | 29 | frmt_header <- function(s) { 30 | if (grepl('^HTTP_', s)) { 31 | s <- sub('^HTTP_', '', s) 32 | } 33 | 34 | cap <- function(.s) { 35 | paste0(toupper(substring(.s, 1, 1)), tolower(substring(.s, 2))) 36 | } 37 | 38 | collapse(lapply(strsplit(s, '_'), cap)[[1]], sep = '-') 39 | } 40 | 41 | is_named <- function(l) { 42 | length(l) != 0 && all(names(l) != '') && all(!is.null(names(l))) 43 | } 44 | 45 | set_names <- function(x, names) { 46 | names(x) <- names 47 | x 48 | } 49 | 50 | # borrowed from expressjs 51 | is_absolute <- function(path) { 52 | if (!is.character(path)) { 53 | stop('argument `path` must be of class character', call. = FALSE) 54 | } 55 | if (substr(path, 1, 1) == '/') TRUE 56 | else if (substr(path, 2, 2) == ':' & substr(path, 3, 3) == '\\') TRUE 57 | else if (substr(path, 1, 2) == '\\\\') TRUE 58 | else FALSE 59 | } 60 | 61 | is_readable <- function(path) { 62 | (file.access(path, mode = 4) == 0)[[1]] 63 | } 64 | 65 | conjunction <- function(x, coordinator = 'and') { 66 | if (length(x) == 1) { 67 | x 68 | } else if (length(x) == 2) { 69 | paste(x[[1]], 'and', x[[2]]) 70 | } else { 71 | paste0(paste(x[1:(length(x) - 1)], collapse = ', '), ', and ', 72 | x[[length(x)]]) 73 | } 74 | } 75 | 76 | #' 77 | #' Generate a minimal HTML table from a data frame 78 | #' 79 | #' This internal function is used by as.response() 80 | #' to encode a data frame into its HTML representation. 81 | #' The encoding is intentionally very minimal. 82 | #' Richer encoding would require either a complicated 83 | #' function or importing a heavy-weight package. 84 | #' 85 | #' @param dfrm a data frame 86 | #' @param class an optional CSS class for the table 87 | #' @param id an optional CSS ID for the table 88 | #' 89 | #' @return an HTML representation of a table (character) 90 | #' 91 | #' @import htmltools 92 | #' 93 | simpleHtmlTable = function(dfrm, class=NULL, id=NULL) { 94 | dfrm.f = format(dfrm) 95 | 96 | wrapRow = function(i) { 97 | tags$tr( 98 | lapply(dfrm.f[i,], tags$td) 99 | ) 100 | } 101 | 102 | tags$table(lapply(1:nrow(dfrm.f), wrapRow), class=class, id=id) 103 | } 104 | -------------------------------------------------------------------------------- /R/status.R: -------------------------------------------------------------------------------- 1 | #' HTTP Response Status Code 2 | #' 3 | #' Get or set the status code of a response object. 4 | #' 5 | #' @param x A response object. 6 | #' @param value An HTTP status code, \code{1xx} through \code{5xx}, see 7 | #' \code{\link{response}} for details. 8 | #' 9 | #' @export 10 | #' @examples 11 | #' # create a new response 12 | #' res <- response() 13 | #' 14 | #' # default response status 15 | #' status(res) # 200 16 | #' 17 | #' # set the response status 18 | #' status(res) <- 301 19 | #' status(res) 20 | #' 21 | status <- function(x) { 22 | if (!is.response(x)) { 23 | stop('argument `x` must be of class response', call. = FALSE) 24 | } 25 | x[['status_code']] 26 | } 27 | 28 | #' @rdname status 29 | #' @export 30 | `status<-` <- function(x, value) { 31 | if (!is.response(x)) { 32 | stop('argument `x` must be of class response', call. = FALSE) 33 | } 34 | x[['status_code']] <- value 35 | invisible(x) 36 | } 37 | 38 | #' Status Code Reason Phrase 39 | #' 40 | #' Get the corresponding reason phrase for a status code. 41 | #' 42 | #' @param code An HTTP status code. 43 | #' 44 | #' @return 45 | #' 46 | #' The corresponding description of \code{code}, otherwise the empty 47 | #' string. 48 | #' 49 | #' @keywords internal 50 | #' @export 51 | #' @examples 52 | #' reason_phrase(200) 53 | #' reason_phrase('404') 54 | #' 55 | #' reason_phrase(531) 56 | #' 57 | reason_phrase <- function(code) { 58 | if (!(is.numeric(code) || is.character(code))) { 59 | stop('argument `code` must be of class numeric or character', 60 | call. = FALSE) 61 | } 62 | switch( 63 | as.character(code), 64 | '100' = "Continue", 65 | '101' = "Switching Protocols", 66 | '200' = "OK", 67 | '201' = "Created", 68 | '202' = "Accepted", 69 | '203' = "Non-Authoritative Information", 70 | '204' = "No Content", 71 | '205' = "Reset Content", 72 | '206' = "Partial Content", 73 | '300' = "Multiple Choices", 74 | '301' = "Moved Permanently", 75 | '302' = "Found", 76 | '303' = "See Other", 77 | '304' = "Not Modified", 78 | '305' = "Use Proxy", 79 | '307' = "Temporary Redirect", 80 | '400' = "Bad Request", 81 | '401' = "Unauthorized", 82 | '402' = "Payment Required", 83 | '403' = "Forbidden", 84 | '404' = "Not Found", 85 | '405' = "Method Not Allowed", 86 | '406' = "Not Acceptable", 87 | '407' = "Proxy Authentication Required", 88 | '408' = "Request Timeout", 89 | '409' = "Conflict", 90 | '410' = "Gone", 91 | '411' = "Length Required", 92 | '412' = "Precondition Failed", 93 | '413' = "Request Entity Too Large", 94 | '414' = "Request-URI Too Long", 95 | '415' = "Unsupported Media Type", 96 | '416' = "Requested Range Not Satisifable", 97 | '417' = "Expectation Failed", 98 | '500' = "Internal Server Error", 99 | '501' = "Not Implemented", 100 | '502' = "Bad Gateway", 101 | '503' = "Service Unavailable", 102 | '504' = "Gateway Timeout", 103 | '505' = "HTTP Version Not Supported", 104 | "" 105 | ) 106 | } 107 | -------------------------------------------------------------------------------- /R/mockup.R: -------------------------------------------------------------------------------- 1 | #' Mockup a Route 2 | #' 3 | #' Creates a mockup of a route object. A mockup simulates what sort of response 4 | #' is generated by a route given a method, uri, and headers (optional). 5 | #' 6 | #' @param r A route object. 7 | #' 8 | #' @details 9 | #' 10 | #' Unfortunately, \code{httpuv} requires a least one header is specified. 11 | #' Therefore, \code{headers} defaults to and must have at least one field 12 | #' specified. 13 | #' 14 | #' @return 15 | #' 16 | #' A route mockup will return the response object returned by the route handler. 17 | #' However, if the method passed to the mockup is not handled by the route or if 18 | #' the path is not handled by the route a 404 response object with a description 19 | #' as the body is returned. 20 | #' 21 | #' @export 22 | #' @name mockup 23 | #' @examples 24 | #' mkup_logger <- mockup( 25 | #' route( 26 | #' 'GET', 27 | #' '^', 28 | #' function(req) { 29 | #' print(req) 30 | #' response() 31 | #' } 32 | #' ) 33 | #' ) 34 | #' 35 | #' mkup_logger('GET', '/yellow/brick/path') 36 | #' mkup_logger('GET', '/phonday', headers = list(Accepts = 'text/html')) 37 | mockup <- function(r) { 38 | if (!is.route(r)) { 39 | stop('cannot create a mockup of ', class(r), ' objects', call. = FALSE) 40 | } 41 | 42 | m <- structure( 43 | function(method, uri, headers = list(`Content-Type` = 'text/plain')) { 44 | if (!is.character(method)) { 45 | stop('argument `method` must be of class character', call. = FALSE) 46 | } 47 | 48 | if (length(method) != 1) { 49 | stop('argument `method` must be a single character string', 50 | call. = FALSE) 51 | } 52 | 53 | if (!is.character(uri)) { 54 | stop('argument `uri` must be of class character', call. = FALSE) 55 | } 56 | 57 | if (length(uri) != 1) { 58 | stop('argument `uri` must be a single character string', call. = FALSE) 59 | } 60 | 61 | if (!is.list(headers)) { 62 | stop('argument `header` must of class list', call. = FALSE) 63 | } 64 | 65 | e <- new.env(parent = emptyenv()) 66 | e$REQUEST_METHOD <- method 67 | split_on_query <- strsplit(uri, '?', fixed = TRUE)[[1]] 68 | e$PATH_INFO <- split_on_query[1] 69 | e$QUERY_STRING <- if (length(split_on_query) > 1) split_on_query[2] else '' 70 | for (nm in names(headers)) { 71 | e[[nm]] <- paste0('HTTP_', headers[[nm]]) 72 | } 73 | req <- as.request(e) 74 | 75 | if (is_match(r, req)) { 76 | res <- r$handler(req) 77 | 78 | if (!is.response(res)) { 79 | stop('route handler returned ', class(res), ', not response', 80 | call. = FALSE) 81 | } 82 | } else { 83 | res <- response() 84 | status(res) <- 404 85 | body(res) <- paste0( 86 | 'The method, uri combination could not be handled by the route.\n\n', 87 | format(route), 88 | format(request) 89 | ) 90 | } 91 | 92 | invisible(res) 93 | }, 94 | class = c('mockup', class(r)) 95 | ) 96 | 97 | attr(m, 'source') <- r 98 | 99 | m 100 | } 101 | 102 | print.mockup <- function(x, ...) { 103 | print.route(attr(x, 'source', exact = TRUE)) 104 | } 105 | -------------------------------------------------------------------------------- /R/request-request-line.R: -------------------------------------------------------------------------------- 1 | #' Request Method 2 | #' 3 | #' Get information about a request such as method type, the requested resource 4 | #' uri, the query component, or the requset HTTP protocol. 5 | #' 6 | #' @param x A request object. 7 | #' 8 | #' @family HTTP request request-line 9 | #' 10 | #' @export 11 | #' @examples 12 | #' 13 | #' methodical <- route( 14 | #' c('GET', 'POST'), 15 | #' '^', 16 | #' function(req) { 17 | #' res <- response() 18 | #' 19 | #' if (method(req) == 'GET') { 20 | #' # handle when method is GET 21 | #' body(res) <- 'I got ya' 22 | #' 23 | #' } else { 24 | #' body(res) <- 'Washingtong or Huffington?' 25 | #' 26 | #' } 27 | #' 28 | #' res 29 | #' } 30 | #' ) 31 | #' 32 | #' methodical_m <- mockup(methodical) 33 | #' 34 | #' res <- methodical_m('GET', '/') 35 | #' res 36 | #' 37 | #' res <- methodical_m('POST', '/') 38 | #' body(res) 39 | #' 40 | method <- function(x) { 41 | if (!is.request(x)) { 42 | stop('argument `x` must be of class request', call. = FALSE) 43 | } 44 | x[['method']] 45 | } 46 | 47 | #' Request URI 48 | #' 49 | #' Get a request's uri. 50 | #' 51 | #' @inheritParams method 52 | #' 53 | #' @family HTTP request request-line 54 | #' 55 | #' @export 56 | #' @examples 57 | #' 58 | #' mkup_name <- mockup( 59 | #' route( 60 | #' 'GET', 61 | #' '^/wizard/[a-z]+$', 62 | #' function(req) { 63 | #' res <- response() 64 | #' 65 | #' # An alternative to passing information 66 | #' # as a request query 67 | #' wizard_name <- gsub('^/wizard/', '', uri(req)) 68 | #' 69 | #' picker <- list( 70 | #' title = c('The', 'Dark Lord', 'Sir'), 71 | #' name = wizard_name, 72 | #' of = 'of the', 73 | #' adjective = c('Enduring', 'Swift', 'Red', 'Great'), 74 | #' noun = c('Heavens', 'Coldness', 'Winglelings', 'Stars') 75 | #' ) 76 | #' 77 | #' body(res) <- paste( 78 | #' lapply(picker, function(n) n[sample(length(n), 1)]), 79 | #' collapse = ' ' 80 | #' ) 81 | #' 82 | #' res 83 | #' } 84 | #' ) 85 | #' ) 86 | #' 87 | #' res <- mkup_name('GET', '/wizard/jenkins') 88 | #' body(res) 89 | #' 90 | #' res <- mkup_name('GET', '/wizard/merlin') 91 | #' body(res) 92 | #' 93 | #' res <- mkup_name('GET', '/wizard/sparrowhawk') 94 | #' body(res) 95 | #' 96 | uri <- function(x) { 97 | if (!is.request(x)) { 98 | stop('argument `x` must be of class request', call. = FALSE) 99 | } 100 | x[['uri']] 101 | } 102 | 103 | #' Request Query 104 | #' 105 | #' Get a request query. 106 | #' 107 | #' @inheritParams method 108 | #' 109 | #' @family HTTP request request-line 110 | #' 111 | #' @export 112 | #' @examples 113 | #' # This route prints out all query key, value pairs 114 | #' route( 115 | #' 'ALL', 116 | #' '^$', 117 | #' function(req) { 118 | #' if (!is.null(query(req))) { 119 | #' for (n in names(query(req))) { 120 | #' print(paste(n, query(req)[[n]])) 121 | #' } 122 | #' } else { 123 | #' print('The request did not contain a query') 124 | #' } 125 | #' 126 | #' response() 127 | #' } 128 | #' ) 129 | #' 130 | query <- function(x) { 131 | if (!is.request(x)) { 132 | stop('argument `x` must be of class request', call. = FALSE) 133 | } 134 | x[['query']] 135 | } 136 | -------------------------------------------------------------------------------- /man/route.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/route.R 3 | \name{route} 4 | \alias{route} 5 | \alias{is.route} 6 | \title{Routing} 7 | \usage{ 8 | route(method, path, handler) 9 | 10 | is.route(x) 11 | } 12 | \arguments{ 13 | \item{method}{A character vector specifying an HTTP method(s), such as 14 | \code{"get"}, \code{"post"}, or \code{"put"}, case-insensitive.} 15 | 16 | \item{path}{A character string specifying which URI the route will handle.} 17 | 18 | \item{handler}{A function whose return value is an object of class 19 | \code{response}, see the Details section below.} 20 | } 21 | \value{ 22 | A route object. 23 | } 24 | \description{ 25 | Within prairie, a route is thought of as a mapping between any number 26 | of methods, specified by \code{method}\emph{, and a URI,} \code{path}. A 27 | route is never assigned more than a single path. However, because \code{path} 28 | is treated as a \link[base:regex]{regular expression} a single route may be 29 | created to match different client requests. Further details below. 30 | } 31 | \details{ 32 | \subsection{Arguments:}{ 33 | 34 | \strong{\code{method}} 35 | 36 | \code{method} is a character vector which specifies at least one HTTP method. 37 | Alternatively, the keywords \code{"all"} or \code{"ALL"} may be used to 38 | specifiy the route to accept any HTTP method. Custom methods may be used, 39 | but are not advised. 40 | 41 | \code{method} is converted to upper case, so \code{"GET"} and \code{"get"} 42 | are equivalent. 43 | 44 | \strong{\code{path}} 45 | 46 | \code{path} is a character string and is treated as a regular expression. 47 | When specifying a \code{path} it is unnecessary to include a beginning 48 | \code{/}. To create a route for the root resource, \code{'/'}, one may 49 | specify \code{'^$'} as \code{path}. 50 | 51 | \strong{\code{handler}} 52 | 53 | \code{handler} is a function with a single argument \code{req}. When an 54 | application receives a request, this HTTP request is parsed into a 55 | \link{request} object and is made available to \code{handler} as \code{req}. 56 | This allows routes to handle specific HTTP header fields included in the 57 | request as well as arguments passed as part of the URI. 58 | 59 | } 60 | 61 | \subsection{Matching:}{ 62 | 63 | An incoming request is matched to a route by pattern matching each route's 64 | \code{path} to the request's URI. Matches are tested for using 65 | \code{\link{grepl}}. The order routes are added to an application is 66 | important as matches are checked for sequentially and only the handler of the 67 | first matching route is run. 68 | 69 | } 70 | } 71 | \examples{ 72 | # Typically, routes are created and added to an 73 | # application inside app(), but standalone route 74 | # objects may be created and added later. 75 | 76 | # matches only GET requests 77 | route( 78 | 'GET', 79 | '^transformers/[a-z_]+$', 80 | function(req) { 81 | res <- response() 82 | 83 | if (uri(req) == '/transformers/beast_wars') { 84 | body(res) <- 'Right on!' 85 | } else { 86 | body(res) <- 'I can dig that.' 87 | } 88 | 89 | res 90 | } 91 | ) 92 | 93 | # matches both GET and POST requests 94 | route( 95 | c('GET', 'POST'), 96 | '^blog/comments$', 97 | function(req) { 98 | res <- response() 99 | 100 | if (method(req) == 'get') { 101 | body(res) <- 'Get your own comments!' 102 | } else { 103 | body(res) <- 'Thanks for commenting' 104 | } 105 | 106 | res 107 | } 108 | ) 109 | } 110 | \seealso{ 111 | \code{\link{request}}, \code{\link{response}} 112 | } 113 | -------------------------------------------------------------------------------- /tests/testthat/test-response.R: -------------------------------------------------------------------------------- 1 | context('response object / as.response') 2 | 3 | test_that('responses created properly', { 4 | expect_silent(res <- response()) 5 | expect_true(is.response(res)) 6 | expect_false(is.response(data.frame())) 7 | expect_false(is.response(list())) 8 | expect_error(res <- response('whoops!')) 9 | }) 10 | 11 | test_that('is.response succeeds / fails correctly', { 12 | res <- response() 13 | expect_true(is.response(res)) 14 | expect_false(is.response(FALSE)) 15 | expect_false(is.response(3030)) 16 | expect_false(is.response('bombos ether quake')) 17 | }) 18 | 19 | test_that('response defaults set when created', { 20 | res <- response() 21 | expect_equal(res[['Content-Type']], 'text/plain') 22 | expect_equal(status(res), 200) 23 | expect_equal(body(res), '') 24 | }) 25 | 26 | test_that('get values with `[` and `[[`', { 27 | res <- response() 28 | 29 | expect_equal(res[['Content-Type']], 'text/plain') 30 | expect_null(res[['missing']]) 31 | expect_null(res[['whoops']]) 32 | expect_equal(res[c('Content-Type')], list(`Content-Type` = 'text/plain')) 33 | }) 34 | 35 | test_that('set field values with `[[<-`', { 36 | res <- response() 37 | 38 | res[['Connection']] <- 'close' 39 | res[['Content-Length']] <- 3030 40 | res[['Warning']] <- 'challenger approaching' 41 | 42 | expect_equal(res[['Connection']], 'close') 43 | expect_equal(res[['Content-Length']], 3030) 44 | expect_equal(res[['Warning']], 'challenger approaching') 45 | expect_equal(res[c('Connection', 'Content-Length')], list(Connection = 'close', `Content-Length` = 3030)) 46 | }) 47 | 48 | test_that('set fields values with `[<-`', { 49 | res <- response() 50 | 51 | expect_error(res[] <- list('text/html'), 'is_named') 52 | res[] <- list(`Content-Type` = 'text/html', `Referer` = 'http://www.com') 53 | expect_equal(res[['Referer']], 'http://www.com') 54 | 55 | res[c('Content-Length', 'Content-Type')] <- list(3030, 'application/pdf') 56 | expect_equal(res[['Content-Length']], 3030) 57 | }) 58 | 59 | test_that('get status of response with status.response', { 60 | res <- response() 61 | 62 | expect_equal(status(res), 200) 63 | }) 64 | 65 | test_that('set status of response with status<-.response', { 66 | res <- response() 67 | 68 | status(res) <- 301 69 | expect_equal(status(res), 301) 70 | status(res) <- 502 71 | expect_equal(status(res), 502) 72 | }) 73 | 74 | test_that('get body of response with body.response', { 75 | res <- response() 76 | 77 | expect_equal(body(res), '') 78 | }) 79 | 80 | test_that('set body of response with body<-.response', { 81 | res <- response() 82 | 83 | body(res) <- 'head shoulders knees and toes' 84 | expect_equal(body(res), 'head shoulders knees and toes') 85 | body(res) <- 'eyes and ears and mouth and nose' 86 | expect_equal(body(res), 'eyes and ears and mouth and nose') 87 | }) 88 | 89 | test_that('create response from data.frame', { 90 | skip_if_not_installed('jsonlite') 91 | 92 | ffframe <- data.frame(Fish = 'blue', Fox = 'socks') 93 | res <- as.response(ffframe) 94 | 95 | expect_equal(status(res), 200) 96 | expect_equal(body(res), jsonlite::toJSON(ffframe)) 97 | expect_equal(res[['Content-Type']], 'application/json') 98 | }) 99 | 100 | test_that('create response from character (name of file)', { 101 | expect_error(as.response('does-not-exist.html')) 102 | limerick <- as.response('sample-response.html', dir = '.') 103 | expect_is(limerick, 'response') 104 | expect_equal(limerick[['Content-Type']], 'text/html') 105 | expect_true(grepl('krill', body(limerick))) 106 | expect_equal(length(body(limerick)), 1) 107 | }) 108 | 109 | test_that('print response', { 110 | res <- response() 111 | body(res) <- 'If I only had a body...' 112 | 113 | res_output <- paste(capture.output(print(res)), collapse = '') 114 | expect_equal(res_output, 'HTTP/1.1 200 OK \rContent-Type: text/plain\r\rIf I only had a body...\r') 115 | }) 116 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # prairie 2 | 3 | A framework to grow your existing R code into web applications. 4 | 5 | [travis]: https://travis-ci.org/nteetor/prairie.svg?branch=master "@travisbyrum" 6 | [coverage]: https://codecov.io/gh/nteetor/prairie/branch/master/graph/badge.svg "grow the nanobots!" 7 | [cran]: https://www.r-pkg.org/badges/version/prairie "put down some roots" 8 | 9 | ![alt text][travis] ![alt text][coverage] ![alt text][cran] 10 | 11 | Below is a simple prairie application, 12 | 13 | ```R 14 | app( 15 | route( 16 | 'get', 17 | '^$', 18 | function(req) { 19 | res <- response() 20 | 21 | status(res) <- 200 # set status 22 | res[['Content-Type']] <- 'text/html' # set a content type 23 | body(res) <- 'Welcome to prairie!' # set a body 24 | 25 | res 26 | } 27 | ), 28 | # Make sure the list has values with names 29 | # method, path, and handler 30 | list( 31 | method = c('get', 'post'), 32 | path = '^data$', 33 | handler = function(req) { 34 | if (method(req) == 'GET') { 35 | as.response(mtcars) 36 | } else { 37 | print(body(req)) # log to console 38 | 39 | res <- response() 40 | body(res) <- 'Thanks for all the data!' 41 | 42 | res 43 | } 44 | } 45 | ) 46 | ) 47 | ``` 48 | 49 | Work on prairie, when the project was still titled dull, began prior to the release of Shiny version 0.13.0. Prior to version 0.13.0, modularization in Shiny was cumbursome, probably ill-advised, or impossible. Rook, another framework for R, was out of date and, to my knowledge, not well-maintained, if at all. I set out to create an Express-like web framework and during the first couple months of development another package, jug, appeared. Jug takes an Express-like approach to web application contruction using R6 classes. I recommend looking at both [Rook](https://github.com/jeffreyhorner/Rook) and [jug](https://github.com/Bart6114/jug). Rook had a significant impact on the development of the powerful httpuv package. Specifically the format of the request environment available to the `call` function in an httpuv application. If you like dectorators in Python and have any interest in APIs check out the [plumber](https://github.com/trestletech/plumber) package. Jumping back to prairie, mid November of 2015 I decided to move away from Express, changed the project name, and began work on prairie. Prairie is a style of web application construction I believe to be very R-like. Prairie draws inspiration from sinatra and wookie and appears more functional in use. The request and response object construction is reminiscent of django and express (I didn't completely let go). The master version of prairie, going forward, will always be stable. Prairie is not on CRAN yet, so look into `devtools::install_github` if you aren't already familiar with the function and would like to try praire out. 50 | 51 | As the tagline says, prairie is about growing existing code. Even though httpuv uses the same libuv C library used by Node, R is inherently single-threaded and prairie does not have the same aynschronous capabilities of Node or express. Thus, prairie focuses more on utility. Prairie focuses on coercing your existing R classes into the application, route, and response classes central to the framework. The goal is to avoid requiring rewrites of their code base. By creating 52 | your own `as.route` methods one can serve up methodologies, data, and anything else R across the web. I love working with R and I know personally how skeptical programmers are of R as anything more than a statiscal workhorse. With prairie I hope you, an R programmer and enthusiast, can push the boundaries of "acceptable" use cases for R. 53 | 54 | Before I put away my soapbox I have a couple favors to ask, 55 | 56 | 1) Help me make prairie better. Let me know what functionality could be added, what isn't programmer friendly, what documentation could be better, and in general your experience using prairie. 57 | 58 | 2) Help me keep prairie working. A great man once proved any program can be reduced to a single bug, so I bet there is at least one bug in prairie. You can, and I would greatly appreciate, if you create an [issue](https://github.com/nteetor/prairie/issues) for any bugs you discover. 59 | 60 | With that I offer you prairie and hope you will give the package the package a try. We R all capable of making R harder, better, faster, and stronger, so let's do it. 61 | 62 | Nate 63 | -------------------------------------------------------------------------------- /R/application.R: -------------------------------------------------------------------------------- 1 | #' Create an Application 2 | #' 3 | #' A prairie application, simply put, is a list of route objects. When creating 4 | #' an application, \code{\ldots} may be any combination of \R objects with a 5 | #' \code{as.route} implementation, see details. 6 | #' 7 | #' @param \ldots \R objects, coerced to routes. 8 | #' 9 | #' @details 10 | #' 11 | #' In order for prairie to best help \R programmers grow web applications from 12 | #' their existing code many coercion generics have been created and are 13 | #' available for implementation. The, arguably, most important of generic is 14 | #' \code{as.route}. CRAN is ripe with packages which include custom S3 classes. 15 | #' prairie aims to provide a streamlined process for serving these classes 16 | #' across the web. An implementation of \code{as.route} might choose a resouce 17 | #' path based on a class attribute or choose the HTTP method based on object 18 | #' permissions (GET for a read-only database connection or GET and POST for a 19 | #' read/write connection). 20 | #' 21 | #' Furthmore, prairie is meant to work on top of, around, and with existing \R 22 | #' code. While writing a good implementation of \code{as.route} may take time, 23 | #' if this package is succesful, one will not need to modify existing code. You 24 | #' have worked hard on your code and prairie is along to grow that code onwards 25 | #' to the web. 26 | #' 27 | #' @seealso \code{\link{as.route}}, \code{\link{run}} 28 | #' 29 | #' @export 30 | #' @examples 31 | #' app( 32 | #' route( 33 | #' 'GET', 34 | #' '^', 35 | #' function(req) { 36 | #' res <- response() 37 | #' body(res) <- 'Hello, world!' 38 | #' res 39 | #' } 40 | #' ) 41 | #' ) 42 | #' 43 | application <- function(...) { 44 | routes <- lapply(list(...), as.route) 45 | 46 | structure( 47 | list( 48 | routes = routes 49 | ), 50 | class = 'application' 51 | ) 52 | } 53 | 54 | #' @rdname application 55 | #' @export 56 | app <- application 57 | 58 | #' @rdname application 59 | #' @export 60 | is.application <- function(x) { 61 | inherits(x, 'application') 62 | } 63 | 64 | #' Print an Application 65 | #' 66 | #' Prints an application. 67 | #' 68 | #' @param x An application. 69 | #' @param \ldots Ignored. 70 | #' 71 | #' @keywords internal 72 | #' @export 73 | print.application <- function(x, ...) { 74 | cat(format(x)) 75 | invisible(x) 76 | } 77 | 78 | #' @rdname print.application 79 | #' @export 80 | format.application <- function(x, ...) { 81 | paste( 82 | paste('# An application:', length(x[['routes']]), 'routes'), 83 | paste( 84 | vapply(x[['routes']], format, character(1)), 85 | collapse = '\n' 86 | ), 87 | sep = '\n' 88 | ) 89 | } 90 | 91 | #' Start Up a Prairie Application 92 | #' 93 | #' Run an application at host \code{host} on port number \code{port}. 94 | #' 95 | #' @param app An application object. 96 | #' @param host A character string specifying the host name. 97 | #' @param port An numeric specifying the port number. 98 | #' 99 | #' @export 100 | #' @name run 101 | run <- function(app, host, port) { 102 | if (!is.application(app)) { 103 | stop('argument `app` must be of class application', call. = FALSE) 104 | } 105 | 106 | if (!is.character(host)) { 107 | stop('argument `host` must be of class character', call. = FALSE) 108 | } 109 | 110 | if (!is.numeric(port)) { 111 | stop('argument `port` must be of class numeric', call. = FALSE) 112 | } 113 | 114 | httpuv::runServer( 115 | host, 116 | port, 117 | list( 118 | call = function(req) { 119 | req <- as.request(req) 120 | 121 | matching_route <- find_route(app[['routes']], req) 122 | 123 | if (is.null(matching_route)) { 124 | return( 125 | list( 126 | status = 404, 127 | headers = list(`Content-Type` = 'text/plain'), 128 | body = 'Sorry, page not found.' 129 | ) 130 | ) 131 | } 132 | 133 | req$ROUTE_PATH <- matching_route[['path']] 134 | res <- matching_route[['handler']](req) 135 | 136 | if (!is.response(res)) { 137 | return( 138 | list( 139 | status = 500, 140 | headers = list(`Content-Type` = 'text/plain'), 141 | body = 'Internal error, no response generated.' 142 | ) 143 | ) 144 | } 145 | 146 | as.list(res) 147 | } 148 | ) 149 | ) 150 | } 151 | 152 | find_route <- function(routes, req) { 153 | Find(function(r) is_match(r, req), routes, nomatch = NULL) 154 | } 155 | 156 | is_match <- function(rte, req) { 157 | if (!is.route(rte)) { 158 | stop('argument `rte` must be of class route', call. = FALSE) 159 | } 160 | 161 | if (!is.request(req)) { 162 | stop('argument `req` must be of class request', call. = FALSE) 163 | } 164 | 165 | grepl(rte[['path']], req[['uri']]) && 166 | (req[['method']] %in% rte[['method']] || rte[['method']] == 'all') 167 | } 168 | -------------------------------------------------------------------------------- /R/request.R: -------------------------------------------------------------------------------- 1 | #' Create an HTTP Request 2 | #' 3 | #' Request objects store relevant information sent from the client to the server 4 | #' as a part of an HTTP request. Request objects are not typically explicitly 5 | #' created. Instead, a request object is passed as an argument to a route 6 | #' handler. 7 | #' 8 | #' @details 9 | #' 10 | #' Request objects contain the following information. 11 | #' 12 | #' \subsection{method:}{ 13 | #' 14 | #' Most often \code{GET} or \code{POST}, the method indicates what action to 15 | #' take for a specified resource. This value may be accessed with 16 | #' \code{\link{method}}. 17 | #' 18 | #' } 19 | #' 20 | #' \subsection{uri:}{ 21 | #' 22 | #' The uri indicates the server resource requested by the client. A request 23 | #' object's uri may be accessed with \code{\link{uri}}. 24 | #' 25 | #' } 26 | #' 27 | #' \subsection{query:}{ 28 | #' 29 | #' A request query is set of key value pairs following the uri. A query is 30 | #' indicated by a ? and is, optionally, ended with a #. Query keys are case- 31 | #' sensitive. A request object's query list may be accessed with \link{query}. 32 | #' If an incoming request does not have a query string then \code{query} will 33 | #' return an empty list. 34 | #' 35 | #' } 36 | #' 37 | #' \subsection{headers:}{ 38 | #' 39 | #' Request header fields may be accessed by treating a request object like a 40 | #' list. Using [ or [[, one can get a single or multiple header field values. 41 | #' Header fields are case-insensitive. 42 | #' 43 | #' } 44 | #' 45 | #' \subsection{body:}{ 46 | #' 47 | #' The body message of a request object may be retreived with \link{body}. 48 | #' 49 | #' } 50 | #' 51 | #' @export 52 | #' @examples 53 | #' # not much to see here 54 | #' req <- request() 55 | #' print(req) 56 | #' 57 | #' # the request object is loaded with information 58 | #' # from the client 59 | #' printreq <- route( 60 | #' 'GET', 61 | #' '^/print/request$', 62 | #' function(req) { 63 | #' print('Request received:') 64 | #' print(req) 65 | #' 66 | #' response() 67 | #' } 68 | #' ) 69 | #' 70 | #' # create mockup 71 | #' printreq_m <- mockup(printreq) 72 | #' 73 | #' # now there's something to see 74 | #' printreq_m('get', '/print/request') 75 | #' printreq_m('get', '/print/request', 76 | #' headers = list( 77 | #' Accept = 'text/html', 78 | #' Host = 'with the most' 79 | #' ) 80 | #' ) 81 | request <- function() { 82 | structure( 83 | list( 84 | method = NULL, 85 | uri = NULL, 86 | query = NULL, 87 | headers = list(`Content-Type` = 'plain/text'), 88 | body = '' 89 | ), 90 | class = 'request' 91 | ) 92 | } 93 | 94 | #' @rdname request 95 | #' @export 96 | is.request <- function(x) { 97 | inherits(x, 'request') 98 | } 99 | 100 | #' Printing Requests 101 | #' 102 | #' Print a request object. 103 | #' 104 | #' @param x A request object. 105 | #' @param \ldots Ignored. 106 | #' 107 | #' @seealso \code{\link{request}} 108 | #' 109 | #' @keywords internal 110 | #' @export 111 | #' @examples 112 | #' print(request()) 113 | #' 114 | print.request <- function(x, ...) { 115 | cat(format(x)) 116 | invisible(x) 117 | } 118 | 119 | #' @rdname print.request 120 | #' @export 121 | format.request <- function(x, ...) { 122 | str_m <- x[['method']] %||% 'NULL' 123 | str_u <- x[['uri']] %||% 'NULL' 124 | str_q <- x[['query']] %||% 'NULL' 125 | str_b <- if (x[['body']] == '') '""' else x[['body']] 126 | str_h <- paste0(names(x[['headers']]), ': ', ifelse(is.date(x[['headers']]), 127 | http_date(x[['headers']]), 128 | x[['headers']])) 129 | 130 | width <- max(nchar(str_m), nchar(str_u), nchar(str_q), nchar(str_h)) 131 | frmt <- paste0('%', width, 's') 132 | 133 | formatted <- c( 134 | 'A request:', 135 | paste(sprintf(frmt, str_m), ''), 136 | paste(sprintf(frmt, str_u), ''), 137 | paste(sprintf(frmt, str_q), ''), 138 | paste(sprintf(frmt, str_h), '
'), 139 | paste(sprintf(frmt, str_b), '') 140 | ) 141 | 142 | paste('#', formatted, collapse = '\n') 143 | } 144 | 145 | #' Coerce Rook Environments to Requests 146 | #' 147 | #' Internally, this function is used to coerce the request environment objects 148 | #' \code{httpuv} passes to an application's \code{call} function. Request 149 | #' environment objects are coerced to objects. 150 | #' 151 | #' @param x An \R object. 152 | #' 153 | #' @seealso \code{\link{request}} 154 | #' 155 | #' @keywords internal 156 | #' 157 | #' @export 158 | #' @examples 159 | #' e <- new.env(parent = emptyenv()) 160 | #' 161 | #' e$REQUEST_METHOD <- 'GET' 162 | #' e$PATH_INFO <- '/file/download' 163 | #' e$HTTP_ACCEPT <- 'application/json' 164 | #' e$HTTP_CONTENT_LENGTH <- '0' 165 | #' 166 | #' req <- as.request(e) 167 | #' is.request(req) # TRUE 168 | #' 169 | #' method(req) 170 | #' uri(req) 171 | #' req[['Accept']] 172 | #' req[['Content-Length']] 173 | #' 174 | as.request <- function(x) { 175 | UseMethod('as.request') 176 | } 177 | 178 | #' @rdname as.request 179 | #' @export 180 | as.request.environment <- function(x) { 181 | req <- request() 182 | 183 | req$method <- toupper(x$REQUEST_METHOD) 184 | req$uri <- sub('^/', '', x$PATH_INFO) 185 | 186 | if (length(x$QUERY_STRING) && x$QUERY_STRING != "?") { 187 | query <- strsplit(sub("^\\?", "", x$QUERY_STRING), "&", fixed = TRUE)[[1]] 188 | req$query <- as.list(sub("^.*=", "", query)) 189 | names(req$query) <- sub("=.*$", "", query) 190 | } else { 191 | req$query <- list() 192 | } 193 | 194 | headers <- grep('^HTTP_', names(x), value = TRUE) 195 | req$headers <- mget(headers, envir = x) 196 | names(req$headers) <- vapply(headers, frmt_header, character(1)) 197 | 198 | if (is.function(x[["rook.input"]][["read_lines"]])) { 199 | req$body <- x[['rook.input']][['read_lines']]() 200 | } 201 | 202 | req 203 | } 204 | -------------------------------------------------------------------------------- /R/response.R: -------------------------------------------------------------------------------- 1 | #' Create an HTTP Response 2 | #' 3 | #' A response object represents the HTTP response returned by a route handler. A 4 | #' response is typically made up of a status, HTTP headers, and a body. A 5 | #' response body is optional. 6 | #' 7 | #' @param status (numeric) HTTP status code, e.g. 200 for OK, 404 for Not Found 8 | #' @param content_type (character) MIME content type, e.g., "text/plain", "text/html". 9 | #' @param body (character) Body of the response 10 | #' 11 | #' @section Components: 12 | #' 13 | #' \subsection{status:}{ 14 | #' 15 | #' Set the status of a response to indicate what action, if any, the client 16 | #' needs to take. Otherwise a status of 2XX indicates a client request was 17 | #' valid and the response object contains the requested resource. 18 | #' 19 | #' Below are descriptions for each status code class, 20 | #' 21 | #' \describe{ 22 | #' 23 | #' \item{1xx:}{Informational - Request received, continuing process} 24 | #' 25 | #' \item{2xx:}{Success - The action was successfully received, understood, and 26 | #' accepted} 27 | #' 28 | #' \item{3xx:}{Redirection - Further action must be taken in order to complete 29 | #' the request} 30 | #' 31 | #' \item{4xx:}{Client Error - The request contains bad syntax or cannot be 32 | #' fulfilled} 33 | #' 34 | #' \item{5xx:}{Server Error - The server failed to fulfill an apparently valid 35 | #' request} 36 | #' 37 | #' } 38 | #' 39 | #' } 40 | #' 41 | #' \subsection{headers:}{ 42 | #' 43 | #' stub 44 | #' 45 | #' } 46 | #' 47 | #' \subsection{body:}{ 48 | #' 49 | #' stub 50 | #' 51 | #' } 52 | #' 53 | #' @seealso \code{\link{route}}, \code{\link{request}} 54 | #' 55 | #' @export 56 | #' @name response 57 | #' @examples 58 | #' # a route to return a client-requested status 59 | #' # and reason phrase 60 | #' mkup <- mockup( 61 | #' route( 62 | #' 'GET', 63 | #' '^\\d+', 64 | #' function(req) { 65 | #' stts <- sub('/', '', uri(req)) 66 | #' 67 | #' res <- response() 68 | #' 69 | #' status(res) <- 200 70 | #' body(res) <- paste(stts, reason_phrase(stts)) 71 | #' 72 | #' res 73 | #' } 74 | #' ) 75 | #' ) 76 | #' 77 | #' mkup('get', '302') 78 | #' mkup('get', '203') 79 | #' 80 | response <- function(status=200, content_type='text/plain', body='') { 81 | structure( 82 | list( 83 | status_code = status, 84 | headers = list( 85 | `Content-Type` = content_type 86 | ), 87 | body = body 88 | ), 89 | class = 'response' 90 | ) 91 | } 92 | 93 | #' Coerce Objects to Responses 94 | #' 95 | #' The \code{as.response} functions simplify serving up R objects as server 96 | #' responses. 97 | #' 98 | #' @param x Any \R object. 99 | #' @param \ldots Additional arguments passed on to methods. 100 | #' 101 | #' @details 102 | #' 103 | #' \code{as.response.character} expects \code{x} is a character string 104 | #' specifying a file name. The default directory for the file is "views", but a 105 | #' different path may be specified with the \code{directory} argument. If the 106 | #' file exists the contents are read and set as the response body. The response 107 | #' Content-Type is guessed from the file extension using 108 | #' \code{\link[mime]{guess_type}}. 109 | #' 110 | #' \code{as.response.data.frame} coerces and serves up a data frame. 111 | #' Several response types are possible. 112 | #' \itemize{ 113 | #' \item CSV (text/csv) - Same format as \link{write.csv}, without row names. 114 | #' \item HTML (text/html) - Formatted by \link{simpleHtmlTable}. 115 | #' Additional arguments may be passed to the formatter using \code{\ldots}. 116 | #' \item JSON (application/json) - The 117 | #' data frame is coerced using the \code{\link{as.json}} function and additional 118 | #' arguments may be passed to \code{as.json} using \code{\ldots}. 119 | #' \item Text (text/plain) - Simple text rendering. 120 | #' } 121 | #' 122 | #' @rdname as.response 123 | #' @export 124 | #' @examples 125 | #' 126 | as.response <- function(x, ...) { 127 | UseMethod('as.response') 128 | } 129 | 130 | #' @param directory A character string specifying the system folder of the file 131 | #' \code{x}. 132 | #' @param collapse A character string specifying how to collapse the lines read 133 | #' from \code{x}. 134 | #' @rdname as.response 135 | #' @export 136 | as.response.character <- function(x, directory = 'views', collapse = '\n', ...) { 137 | if (length(x) != 1) { 138 | stop('expecting argument `x` to be a single character string', 139 | call. = FALSE) 140 | } 141 | 142 | path <- file.path(directory, x) 143 | 144 | if (!file.exists(path)) { 145 | stop('file "', path, '" does not exist', call. = FALSE) 146 | } 147 | 148 | if (!is_readable(path)) { 149 | stop('do not have read permissions for "', path, '"', call. = FALSE) 150 | } 151 | 152 | res <- response() 153 | res[['Content-Type']] <- mime::guess_type(path) 154 | 155 | contents <- paste(readLines(path, warn = FALSE), collapse = collapse) 156 | body(res) <- contents 157 | 158 | res 159 | } 160 | 161 | #' @param format A character string, determining the form of the HTTP response. 162 | #' Can be one of \code{"csv"}, \code{"html"}, \code{"json"}, or \code{"text"}. 163 | #' @rdname as.response 164 | #' @export 165 | as.response.data.frame <- function(x, format="json", ...) { 166 | switch(format, 167 | json = response(content_type = "application/json", 168 | body = as.json(x, ...) ), 169 | html = response(content_type = "text/html", 170 | body = as.character(simpleHtmlTable(x, ...)) ), 171 | csv = { 172 | theText = NULL 173 | con = textConnection(theText, open="w", local=TRUE) 174 | write.csv(x, file=con, row.names=FALSE) 175 | body = paste(textConnectionValue(con), collapse="\n") 176 | response(content_type = "text/csv", 177 | body = body ) 178 | }, 179 | text = response(content_type = "text/plain", 180 | body = capture.output(print(x)) ), 181 | stop("prairie: Invalid response format: ", format) ) 182 | } 183 | 184 | #' @rdname as.response 185 | #' @export 186 | as.response.matrix <- function(x, ...) { 187 | as.response.data.frame(as.data.frame(x), ...) 188 | } 189 | 190 | #' @rdname as.response 191 | #' @export 192 | #' @examples 193 | #' is.response(logical(1)) 194 | #' is.response(response()) 195 | #' is.response(3030) 196 | is.response <- function(x) { 197 | inherits(x, 'response') 198 | } 199 | 200 | 201 | #' Printing Responses 202 | #' 203 | #' Print a response object. 204 | #' 205 | #' @param x Object of class \code{response}. 206 | #' @param \ldots Ignored. 207 | #' 208 | #' @details 209 | #' 210 | #' Formats the response as an HTTP response. 211 | #' 212 | #' @seealso \code{\link{response}} 213 | #' 214 | #' @keywords internal 215 | #' @export 216 | print.response <- function(x, ...) { 217 | cat(format(x)) 218 | invisible(x) 219 | } 220 | 221 | #' @keywords internal 222 | #' @export 223 | #' @rdname print.response 224 | format.response <- function(x, ...) { 225 | 226 | str_sc <- paste(x[['status_code']], reason_phrase(x[['status_code']])) 227 | str_h <- paste0(names(x[['headers']]), ': ', ifelse(is.date(x[['headers']]), 228 | http_date(x[['headers']]), 229 | x[['headers']])) 230 | str_b <- if (x[['body']] == '') '""' else x[['body']] 231 | 232 | width <- max(nchar(str_sc), nchar(str_h)) 233 | frmt <- paste0('%', width, 's') 234 | 235 | formatted <- c( 236 | 'A response:', 237 | paste(sprintf(frmt, str_sc), ''), 238 | paste(sprintf(frmt, str_h), '
'), 239 | paste(sprintf(frmt, str_b), '') 240 | ) 241 | 242 | paste('#', formatted, collapse = '\n') 243 | } 244 | -------------------------------------------------------------------------------- /R/route.R: -------------------------------------------------------------------------------- 1 | #' Routing 2 | #' 3 | #' Within prairie, a route is thought of as a mapping between any number 4 | #' of methods, specified by \code{method}\emph{, and a URI,} \code{path}. A 5 | #' route is never assigned more than a single path. However, because \code{path} 6 | #' is treated as a \link[base:regex]{regular expression} a single route may be 7 | #' created to match different client requests. Further details below. 8 | #' 9 | #' @param method A character vector specifying an HTTP method(s), such as 10 | #' \code{"get"}, \code{"post"}, or \code{"put"}, case-insensitive. 11 | #' @param path A character string specifying which URI the route will handle. 12 | #' @param handler A function whose return value is an object of class 13 | #' \code{response}, see the Details section below. 14 | #' 15 | #' @details 16 | #' 17 | #' \subsection{Arguments:}{ 18 | #' 19 | #' \strong{\code{method}} 20 | #' 21 | #' \code{method} is a character vector which specifies at least one HTTP method. 22 | #' Alternatively, the keywords \code{"all"} or \code{"ALL"} may be used to 23 | #' specifiy the route to accept any HTTP method. Custom methods may be used, 24 | #' but are not advised. 25 | #' 26 | #' \code{method} is converted to upper case, so \code{"GET"} and \code{"get"} 27 | #' are equivalent. 28 | #' 29 | #' \strong{\code{path}} 30 | #' 31 | #' \code{path} is a character string and is treated as a regular expression. 32 | #' When specifying a \code{path} it is unnecessary to include a beginning 33 | #' \code{/}. To create a route for the root resource, \code{'/'}, one may 34 | #' specify \code{'^$'} as \code{path}. 35 | #' 36 | #' \strong{\code{handler}} 37 | #' 38 | #' \code{handler} is a function with a single argument \code{req}. When an 39 | #' application receives a request, this HTTP request is parsed into a 40 | #' \link{request} object and is made available to \code{handler} as \code{req}. 41 | #' This allows routes to handle specific HTTP header fields included in the 42 | #' request as well as arguments passed as part of the URI. 43 | #' 44 | #' } 45 | #' 46 | #' \subsection{Matching:}{ 47 | #' 48 | #' An incoming request is matched to a route by pattern matching each route's 49 | #' \code{path} to the request's URI. Matches are tested for using 50 | #' \code{\link{grepl}}. The order routes are added to an application is 51 | #' important as matches are checked for sequentially and only the handler of the 52 | #' first matching route is run. 53 | #' 54 | #' } 55 | #' 56 | #' @return 57 | #' 58 | #' A route object. 59 | #' 60 | #' @seealso \code{\link{request}}, \code{\link{response}} 61 | #' 62 | #' @export 63 | #' @examples 64 | #' # Typically, routes are created and added to an 65 | #' # application inside app(), but standalone route 66 | #' # objects may be created and added later. 67 | #' 68 | #' # matches only GET requests 69 | #' route( 70 | #' 'GET', 71 | #' '^transformers/[a-z_]+$', 72 | #' function(req) { 73 | #' res <- response() 74 | #' 75 | #' if (uri(req) == '/transformers/beast_wars') { 76 | #' body(res) <- 'Right on!' 77 | #' } else { 78 | #' body(res) <- 'I can dig that.' 79 | #' } 80 | #' 81 | #' res 82 | #' } 83 | #' ) 84 | #' 85 | #' # matches both GET and POST requests 86 | #' route( 87 | #' c('GET', 'POST'), 88 | #' '^blog/comments$', 89 | #' function(req) { 90 | #' res <- response() 91 | #' 92 | #' if (method(req) == 'get') { 93 | #' body(res) <- 'Get your own comments!' 94 | #' } else { 95 | #' body(res) <- 'Thanks for commenting' 96 | #' } 97 | #' 98 | #' res 99 | #' } 100 | #' ) 101 | route <- function(method, path, handler) { 102 | if (!is.character(method)) { 103 | stop('argument `method` must be of class character', call. = FALSE) 104 | } 105 | 106 | if (!is.character(path)) { 107 | stop('argument `path` must be of class character', call. = FALSE) 108 | } 109 | 110 | if (length(path) != 1) { 111 | stop('argument `path` must be a single character string', call. = FALSE) 112 | } 113 | 114 | if (!is.function(handler)) { 115 | stop('argument `handler` must be a function', call. = FALSE) 116 | } 117 | 118 | if (length(formals(handler)) != 1) { 119 | formals(handler) <- alist(.req = ) 120 | } 121 | 122 | method <- toupper(method) 123 | 124 | structure( 125 | list( 126 | method = method, 127 | path = path, 128 | handler = handler 129 | ), 130 | class = 'route' 131 | ) 132 | } 133 | 134 | #' @rdname route 135 | #' @export 136 | is.route <- function(x) { 137 | inherits(x, 'route') 138 | } 139 | 140 | #' Coercing Objects to Routes 141 | #' 142 | #' The function \code{as.route} provides an alternative means of creating an 143 | #' application route. 144 | #' 145 | #' @param x An \R object. 146 | #' @param \ldots Additional arguments passed on to methods. 147 | #' 148 | #' @details 149 | #' 150 | #' If \code{x} is a list, \code{x} must have the following named elements: 151 | #' \code{method}, \code{path}, and \code{handler}. 152 | #' 153 | #' If \code{x} is a character vector, \code{x} is interpreted as a file name. 154 | #' The file must contain a route defined using the \code{route} function. The 155 | #' default directory for route files is "routes", but a different folder may be 156 | #' specified with the \code{directory} argument. 157 | #' 158 | #' The S3 generic function \code{as.route} is exported by prairie to encourage 159 | #' creation of \code{as.route.*} functions. Custom \code{as.route} functions 160 | #' allow users to coerce their classes to routes and quickly serve them over 161 | #' HTTP. 162 | #' 163 | #' @return 164 | #' 165 | #' A \code{route} object. 166 | #' 167 | #' @seealso \code{\link{route}} 168 | #' 169 | #' @name as.route 170 | #' @export 171 | #' @examples 172 | #' # Easily reuse routes and keep applications 173 | #' # modular by storing routes in separate files. 174 | #' 175 | #' tmp <- tempfile() 176 | #' writeLines( 177 | #' 'route("GET", "^$", function(req) response())\n', 178 | #' con = tmp 179 | #' ) 180 | #' 181 | #' as.route(tmp, dir = '') 182 | #' 183 | #' file.remove(tmp) 184 | #' 185 | #' # as.route.list is a minimal wrapper 186 | #' # around route() 187 | #' 188 | #' route( 189 | #' 'POST', 190 | #' '^$', 191 | #' function(req) { 192 | #' response() 193 | #' } 194 | #' ) 195 | #' 196 | #' as.route( 197 | #' list( 198 | #' method = 'POST', 199 | #' path = '^$', 200 | #' handler = function(req) { 201 | #' response() 202 | #' } 203 | #' ) 204 | #' ) 205 | as.route <- function(x, ...) { 206 | UseMethod('as.route') 207 | } 208 | 209 | #' @export 210 | #' @rdname as.route 211 | as.route.route <- function(x, ...) { 212 | x 213 | } 214 | 215 | #' @param directory System path to the folder containing the route file. 216 | #' @export 217 | #' @rdname as.route 218 | as.route.character <- function(x, directory = 'routes', ...) { 219 | path <- file.path(directory, x) 220 | 221 | if (!file.exists(path)) { 222 | stop('file "', path, '" does not exist', call. = FALSE) 223 | } 224 | 225 | if (!is_readable(path)) { 226 | stop('do not have read permissions for "', path, '"', call. = FALSE) 227 | } 228 | 229 | route <- tryCatch( 230 | source(path)$value, 231 | error = function(e) NULL 232 | ) 233 | 234 | if (!is.route(route)) { 235 | stop('could not parse route from "', path, '"', call. = FALSE) 236 | } 237 | 238 | # drop 'srcref' from handler function 239 | attributes(route$handler) <- NULL 240 | 241 | route 242 | } 243 | 244 | #' @export 245 | #' @rdname as.route 246 | as.route.list <- function(x, ...) { 247 | if (is.null(x[['method']])) { 248 | stop('cannot coerce list to route, missing method', call. = FALSE) 249 | } 250 | if (is.null(x[['path']])) { 251 | stop('cannot coerce list to route, missing path', call. = FALSE) 252 | } 253 | if (is.null(x[['handler']])) { 254 | stop('cannot coerce list to route, missing handler', call. = FALSE) 255 | } 256 | 257 | route(x[['method']], x[['path']], x[['handler']]) 258 | } 259 | 260 | #' Printing Routes and Mockups 261 | #' 262 | #' Prints a route or mockup. Printing a mockup prints the underlying route. 263 | #' 264 | #' @param x A route or route mockup. 265 | #' @param \ldots Ignored. 266 | #' 267 | #' @seealso \code{\link{route}}, \code{\link{mockup}} 268 | #' 269 | #' @keywords internal 270 | #' @export 271 | #' @examples 272 | #' route( 273 | #' c('GET', 'POST'), 274 | #' '^path$', 275 | #' function(req) { 276 | #' response() 277 | #' } 278 | #' ) 279 | #' 280 | #' route( 281 | #' 'put', 282 | #' '^another/path$', 283 | #' function(req) { 284 | #' response() 285 | #' } 286 | #' ) 287 | print.route <- function(x, ...) { 288 | cat(format(x)) 289 | invisible(x) 290 | } 291 | 292 | #' @rdname print.route 293 | #' @export 294 | format.route <- function(x, ...) { 295 | str_m <- collapse(x[['method']]) 296 | str_p <- x[['path']] 297 | str_h <- paste(gsub('\\s+', '', deparse(args(x[['handler']]))[1]), '{..}') 298 | 299 | width <- max(nchar(str_m), nchar(str_p), nchar(str_h)) 300 | frmt <- paste0('%', width, 's') 301 | 302 | formatted <- c( 303 | 'A route:', 304 | paste(sprintf(frmt, str_m), ''), 305 | paste(sprintf(frmt, str_p), ''), 306 | paste(sprintf(frmt, str_h), '') 307 | ) 308 | 309 | paste('#', formatted, collapse = '\n') 310 | } 311 | --------------------------------------------------------------------------------