plumber/0000755000176200001440000000000013305412327011720 5ustar liggesusersplumber/inst/0000755000176200001440000000000013305335716012703 5ustar liggesusersplumber/inst/examples/0000755000176200001440000000000013304040260014503 5ustar liggesusersplumber/inst/examples/01-append/0000755000176200001440000000000013304040260016170 5ustar liggesusersplumber/inst/examples/01-append/plumber.R0000644000176200001440000000132413304040260017761 0ustar liggesusersvalues <- 15 MAX_VALS <- 50 #* Append to our values #* @post /append function(val, res){ v <- as.numeric(val) if (is.na(v)){ res$status <- 400 res$body <- "val parameter must be a number" } values <<- c(values, val) if (length(values) > MAX_VALS){ values <<- tail(values, n=MAX_VALS) } list(result="success") } #* Get the last few values #* @get /tail function(n="10", res){ n <- as.numeric(n) if (is.na(n) || n < 1 || n > MAX_VALS){ res$status <- 400 res$body <- "parameter 'n' must be a number between 1 and 100" } list(val=tail(values, n=n)) } #* Get a graph of the values #* @png #* @get /graph function(){ plot(values, type="b", ylim=c(1,100), main="Recent Values") } plumber/inst/examples/02-filters/0000755000176200001440000000000013304040260016372 5ustar liggesusersplumber/inst/examples/02-filters/plumber.R0000644000176200001440000000323313304040260020164 0ustar liggesuserslibrary(plumber) users <- data.frame( id=1:2, username=c("joe", "kim"), groups=c("users", "admin,users") ) #* Filter that grabs the "username" querystring parameter. #* You should, of course, use a real auth system, but #* this shows the principles involved. #* @filter auth-user function(req, username=""){ # Since username is a querystring param, we can just # expect it to be available as a parameter to the # filter (plumber magic). # This is a work-around for https://github.com/trestletech/plumber/issues/12 # and shouldn't be necessary long-term req$user <- NULL if (username == ""){ # No username provided } else if (username %in% users$username){ # username is valid req$user <- users[users$username == username,] } else { # username was provided, but invalid stop("No such username: ", username) } # Continue on forward() } #* Now require that all users must be authenticated. #* @filter require-auth function(req, res){ if (is.null(req$user)){ # User isn't logged in res$status <- 401 # Unauthorized list(error="You must login to access this resource.") } else { # user is logged in. Move on... forward() } } #* @get /me function(req){ # Safe to assume we have a user, since we've been # through all the filters and would have gotten an # error earlier if we weren't. list(user=req$user) } #* Get info about the service. We preempt the #* require-auth filter because we want authenticated and #* unauthenticated users alike to be able to access this #* endpoint. #* @preempt require-auth #* @get /about function(){ list(descript="This is a demo service that uses authentication!") } plumber/inst/examples/04-mean-sum/0000755000176200001440000000000013304040260016446 5ustar liggesusersplumber/inst/examples/04-mean-sum/plumber.R0000644000176200001440000000024513304040260020240 0ustar liggesusers#* @get /mean normalMean <- function(samples=10){ data <- rnorm(samples) mean(data) } #* @post /sum addTwo <- function(a, b){ as.numeric(a) + as.numeric(b) } plumber/inst/examples/06-sessions/0000755000176200001440000000000013305335716016612 5ustar liggesusersplumber/inst/examples/06-sessions/plumber.R0000644000176200001440000000151113304040260020363 0ustar liggesusers#* @get /counter function(req, res){ count <- 0 if (!is.null(req$cookies$visitcounter)){ count <- as.numeric(req$cookies$visitcounter) } # Most people won't need to concern themselves with the path argument. # I do because of some peculiarities in how I'm hosting the examples. res$setCookie("visitcounter", count+1, path="/") return(paste0("This is visit #", count)) } #* Example using req$session. Requires adding "sessionCookie()" support to your router in order #* to work: #* `pr <- plumb("file.R"); pr$addGlobalProcessor(sessionCookie("secret", "cookieName")); pr$run()` #* @get /sessionCounter function(req){ count <- 0 if (!is.null(req$session$counter)){ count <- as.numeric(req$session$counter) } req$session$counter <- count + 1 return(paste0("This is visit #", count)) } #* @assets static list() plumber/inst/examples/06-sessions/static/0000755000176200001440000000000013304040260020063 5ustar liggesusersplumber/inst/examples/06-sessions/static/iframe-secure.html0000644000176200001440000000306513304040260023504 0ustar liggesusers

Response text

Click "Visit /sessionCounter"

Cookie Value

plumber/inst/examples/06-sessions/static/js-cookie.js0000644000176200001440000000654013304040260022311 0ustar liggesusers/*! * JavaScript Cookie v2.1.0 * https://github.com/js-cookie/js-cookie * * Copyright 2006, 2015 Klaus Hartl & Fagner Brack * Released under the MIT license */ (function (factory) { if (typeof define === 'function' && define.amd) { define(factory); } else if (typeof exports === 'object') { module.exports = factory(); } else { var _OldCookies = window.Cookies; var api = window.Cookies = factory(); api.noConflict = function () { window.Cookies = _OldCookies; return api; }; } }(function () { function extend () { var i = 0; var result = {}; for (; i < arguments.length; i++) { var attributes = arguments[ i ]; for (var key in attributes) { result[key] = attributes[key]; } } return result; } function init (converter) { function api (key, value, attributes) { var result; // Write if (arguments.length > 1) { attributes = extend({ path: '/' }, api.defaults, attributes); if (typeof attributes.expires === 'number') { var expires = new Date(); expires.setMilliseconds(expires.getMilliseconds() + attributes.expires * 864e+5); attributes.expires = expires; } try { result = JSON.stringify(value); if (/^[\{\[]/.test(result)) { value = result; } } catch (e) {} if (!converter.write) { value = encodeURIComponent(String(value)) .replace(/%(23|24|26|2B|3A|3C|3E|3D|2F|3F|40|5B|5D|5E|60|7B|7D|7C)/g, decodeURIComponent); } else { value = converter.write(value, key); } key = encodeURIComponent(String(key)); key = key.replace(/%(23|24|26|2B|5E|60|7C)/g, decodeURIComponent); key = key.replace(/[\(\)]/g, escape); return (document.cookie = [ key, '=', value, attributes.expires && '; expires=' + attributes.expires.toUTCString(), // use expires attribute, max-age is not supported by IE attributes.path && '; path=' + attributes.path, attributes.domain && '; domain=' + attributes.domain, attributes.secure ? '; secure' : '' ].join('')); } // Read if (!key) { result = {}; } // To prevent the for loop in the first place assign an empty array // in case there are no cookies at all. Also prevents odd result when // calling "get()" var cookies = document.cookie ? document.cookie.split('; ') : []; var rdecode = /(%[0-9A-Z]{2})+/g; var i = 0; for (; i < cookies.length; i++) { var parts = cookies[i].split('='); var name = parts[0].replace(rdecode, decodeURIComponent); var cookie = parts.slice(1).join('='); if (cookie.charAt(0) === '"') { cookie = cookie.slice(1, -1); } try { cookie = converter.read ? converter.read(cookie, name) : converter(cookie, name) || cookie.replace(rdecode, decodeURIComponent); if (this.json) { try { cookie = JSON.parse(cookie); } catch (e) {} } if (key === name) { result = cookie; break; } if (!key) { result[name] = cookie; } } catch (e) {} } return result; } api.get = api.set = api; api.getJSON = function () { return api.apply({ json: true }, [].slice.call(arguments)); }; api.defaults = {}; api.remove = function (key, attributes) { api(key, '', extend(attributes, { expires: -1 })); }; api.withConverter = init; return api; } return init(function () {}); })); plumber/inst/examples/06-sessions/static/iframe.html0000644000176200001440000000304413304040260022215 0ustar liggesusers

Response text

Click "Visit /counter"

Cookie Value

plumber/inst/examples/08-identity/0000755000176200001440000000000013304040260016561 5ustar liggesusersplumber/inst/examples/08-identity/plumber.R0000644000176200001440000000006613304040260020354 0ustar liggesusers#* @get /name function(){ Sys.info()[["nodename"]] } plumber/inst/examples/09-content-type/0000755000176200001440000000000013304040260017362 5ustar liggesusersplumber/inst/examples/09-content-type/plumber.R0000644000176200001440000000231013304040260021147 0ustar liggesusers#* @serializer contentType list(type="application/pdf") #* @get /pdf function(){ tmp <- tempfile() pdf(tmp) plot(1:10, type="b") text(4, 8, "PDF from plumber!") dev.off() readBin(tmp, "raw", n=file.info(tmp)$size) } #* @serializer contentType list(type="text/plain") #* @get /text function(){ "just plain text here..." } #* @serializer contentType list(type="text/html") #* @get /html function(){ "

HTML!

HTML here!" } #* Download a binary file. #* @serializer contentType list(type="application/octet-stream") #* @get /download-binary function(res){ # TODO: Stream the data into the response rather than loading it all in memory # first. # Create a temporary example RDS file x <- list(a=123, b="hi!") tmp <- tempfile(fileext=".rds") saveRDS(x, tmp) # This header is a convention that instructs browsers to present the response # as a download named "mydata.Rds" rather than trying to render it inline. res$setHeader("Content-Disposition", "attachment; filename=mydata.Rds") # Read in the raw contents of the binary file bin <- readBin(tmp, "raw", n=file.info(tmp)$size) # Delete the temp file file.remove(tmp) # Return the binary contents bin } plumber/inst/examples/12-entrypoint/0000755000176200001440000000000013304040260017136 5ustar liggesusersplumber/inst/examples/12-entrypoint/myplumberapi.R0000644000176200001440000000032413304040260021766 0ustar liggesusers#* @get /counter function(req){ count <- 0 if (!is.null(req$session$counter)){ count <- as.numeric(req$session$counter) } req$session$counter <- count + 1 return(paste0("This is visit #", count)) } plumber/inst/examples/12-entrypoint/entrypoint.R0000644000176200001440000000014013304040260021467 0ustar liggesusers pr <- plumb("myplumberapi.R") pr$addGlobalProcessor(sessionCookie("secret", "cookieName")) pr plumber/inst/examples/11-car-inventory/0000755000176200001440000000000013304040260017522 5ustar liggesusersplumber/inst/examples/11-car-inventory/plumber.R0000644000176200001440000000570113304040260021316 0ustar liggesusersinventory <- read.csv("inventory.csv", stringsAsFactors = FALSE) #* @apiTitle Auto Inventory Manager #* @apiDescription Manage the inventory of an automobile #* store using an API. #* @apiTag cars Functionality having to do with the management of #* car inventory. #* List all cars in the inventory #* @get /car/ #* @tag cars listCars <- function(){ inventory } #* Lookup a car by ID #* @param id The ID of the car to get #* @get /car/ #* @response 404 No car with the given ID was found in the inventory. #* @tag cars getCar <- function(id, res){ car <- inventory[inventory$id == id,] if (nrow(car) == 0){ res$status <- 404 } car } validateCar <- function(make, model, year){ if (missing(make) || nchar(make) == 0){ return("No make specified") } if (missing(model) || nchar(model) == 0){ return("No make specified") } if (missing(year) || as.integer(year) == 0){ return("No year specified") } NULL } #* Add a car to the inventory #* @post /car/ #* @param make:character The make of the car #* @param model:character The model of the car #* @param edition:character Edition of the car #* @param year:int Year the car was made #* @param miles:int The number of miles the car has #* @param price:numeric The price of the car in USD #* @response 400 Invalid user input provided #* @tag cars addCar <- function(make, model, edition, year, miles, price, res){ newId <- max(inventory$id) + 1 valid <- validateCar(make, model, year) if (!is.null(valid)){ res$status <- 400 return(list(errors=paste0("Invalid car: ", valid))) } car <- list( id = newId, make = make, model = model, edition = edition, year = year, miles = miles, price = price ) inventory <<- rbind(inventory, car) getCar(newId) } #* Update a car in the inventory #* @param id:int The ID of the car to update #* @param make:character The make of the car #* @param model:character The model of the car #* @param edition:character Edition of the car #* @param year:int Year the car was made #* @param miles:int The number of miles the car has #* @param price:numeric The price of the car in USD #* @put /car/ #* @tag cars updateCar <- function(id, make, model, edition, year, miles, price, res){ valid <- validateCar(make, model, year) if (!is.null(valid)){ res$status <- 400 return(list(errors=paste0("Invalid car: ", valid))) } updated <- list( id = id, make = make, model = model, edition = edition, year = year, miles = miles, price = price ) if (!(id %in% inventory$id)){ stop("No such ID: ", id) } inventory[inventory$id == id, ] <<- updated getCar(id) } #* Delete a car from the inventory #* @param id:int The ID of the car to delete #* @delete /car/ #* @tag cars deleteCar <- function(id, res){ if (!(id %in% inventory$id)){ res$status <- 400 return(list(errors=paste0("No such ID: ", id))) } inventory <<- inventory[inventory$id != id,] } plumber/inst/examples/11-car-inventory/inventory.csv0000644000176200001440000000112613304040260022274 0ustar liggesusersid,make,model,edition,year,miles,price 12049293,Ford,Focus,SE,2016,16827,15000 12049294,GMC,Terrain,SLE-1,2012,23899,15000 12049295,Ford,Escape,SE,2013,48527,15000 12049296,Chevrolet,Silverado,Extended Cab,2000,278806,11500 12049297,Ford,Mustang,GT,1995,73500,9997 12049298,Volvo,S40,2.4i,2007,127733,6000 12049299,Nissan,Maxima,GLE,2003,144000,2450 12049300,Ford,Focus,ST,2014,50776,14991 12049301,Buick,Encore,,2014,77389,14542 12049302,Buick,Regal,,2013,19569,14495 12049303,Ford,Edge,SE,2013,54100,14491 12049304,Toyota,Highlander,,2011,104133,14393 12049305,Toyota,Corolla,LE,2014,25924,13991 plumber/inst/examples/07-mailgun/0000755000176200001440000000000013305335716016401 5ustar liggesusersplumber/inst/examples/07-mailgun/plumber.R0000644000176200001440000000052213304040260020153 0ustar liggesusersemails <- data.frame(from=character(0), time=character(0), subject=character(0), stringsAsFactors = FALSE) #* @post /mail function(from, subject){ emails <<- rbind(emails, data.frame(from=from, time=date(), subject=htmltools::htmlEscape(subject), stringsAsFactors=FALSE)) TRUE } #* @get /tail function(){ tail(emails[,-1], n=5) } plumber/inst/examples/10-welcome/0000755000176200001440000000000013304040260016354 5ustar liggesusersplumber/inst/examples/10-welcome/plumber.R0000644000176200001440000000013213304040260020141 0ustar liggesusers#* @get / #* @html function(){ "

plumber is alive!

" } plumber/inst/examples/03-github/0000755000176200001440000000000013305335716016223 5ustar liggesusersplumber/inst/examples/03-github/plumber.R0000644000176200001440000000147713304040260020007 0ustar liggesusers#* Get information about the currently available #* @get /version function(){ desc <- read.dcf(system.file("DESCRIPTION", package="plumber")) resp <- list( version = unname(desc[1,"Version"]), built = unname(desc[1,"Built"]) ) if ("GithubSHA1" %in% colnames(desc)){ resp["sha1"] <- unname(desc[1,"GithubSHA1"]) } resp } #* Give GitHub Webhook a way to alert us about new pushes to the repo #* https://developer.github.com/webhooks/ #* @post /update function(req, res){ secret <- readLines("./github-key.txt")[1] hm <- digest::hmac(secret, req$postBody, algo="sha1") hm <- paste0("sha1=", hm) if (!identical(hm, req$HTTP_X_HUB_SIGNATURE)){ res$status <- 400 res$body <- "invalid GitHub signature." return(res) } # DO... devtools::install_github("trestletech/plumber") TRUE } plumber/inst/examples/05-static/0000755000176200001440000000000013304040260016214 5ustar liggesusersplumber/inst/examples/05-static/README.md0000644000176200001440000000051513304040260017474 0ustar liggesusers## Static File Server This example sets up two static file servers. One at the default path (`/public`), and another at an explicit path (`/static`). You should be able to access the two files in the `./files` directory at either of those paths. So try `http://localhost:8000/static/b.txt` or `http://localhost:8000/public/a.html`. plumber/inst/examples/05-static/files/0000755000176200001440000000000013304040260017316 5ustar liggesusersplumber/inst/examples/05-static/files/a.html0000644000176200001440000000015313304040260020423 0ustar liggesusers Hello, plumber world

Success!

plumber/inst/examples/05-static/files/b.txt0000644000176200001440000000002013304040260020270 0ustar liggesuserstext file here! plumber/inst/examples/05-static/plumber.R0000644000176200001440000000007513304040260020007 0ustar liggesusers#* @assets ./files list() #* @assets ./files /static list() plumber/inst/server/0000755000176200001440000000000013304040260014173 5ustar liggesusersplumber/inst/server/plumber.service0000644000176200001440000000042313304040260017222 0ustar liggesusers[Unit] Description=Plumber API [Service] ExecStart=/usr/bin/Rscript -e "pr <- plumber::plumb('/var/plumber$PATH$/plumber.R'); $PREFLIGHT$ pr$run(port=$PORT$, swagger=$SWAGGER$)" Restart=on-abnormal WorkingDirectory=/var/plumber/$PATH$/ [Install] WantedBy=multi-user.target plumber/inst/server/nginx-ssl.conf0000644000176200001440000000071513304040260016767 0ustar liggesusersserver { listen 80 default_server; listen [::]:80 default_server; server_name $DOMAIN$; return 301 https://$server_name$request_uri; } server { listen 443 ssl; listen [::]:443 ssl; server_name $DOMAIN$; ssl_certificate /etc/letsencrypt/live/$DOMAIN$/fullchain.pem; ssl_certificate_key /etc/letsencrypt/live/$DOMAIN$/privkey.pem; include /etc/nginx/sites-available/plumber-apis/*; location /.well-known/ { root /var/certbot/; } } plumber/inst/server/nginx.conf0000644000176200001440000000035013304040260016163 0ustar liggesusers# Plumber server configuration server { listen 80 default_server; listen [::]:80 default_server; server_name _; include /etc/nginx/sites-available/plumber-apis/*; location /.well-known/ { root /var/certbot/; } } plumber/inst/server/forward.conf0000644000176200001440000000004713304040260016507 0ustar liggesuserslocation = / { return 307 /$PATH$; } plumber/inst/server/plumber-api.conf0000644000176200001440000000013413304040260017255 0ustar liggesuserslocation /$PATH$/ { proxy_pass http://localhost:$PORT$/; proxy_set_header Host $host; } plumber/inst/swagger-ui/0000755000176200001440000000000013304040260014737 5ustar liggesusersplumber/inst/swagger-ui/index.html0000644000176200001440000001076013304040260016740 0ustar liggesusers Swagger UI
plumber/inst/hosted-new.R0000644000176200001440000000206013304040260015063 0ustar liggesuserslibrary(analogsea) library(plumber) install_package_secure <- function(droplet, pkg){ analogsea::install_r_package(droplet, pkg, repo="https://cran.rstudio.com") } drop <- plumber::do_provision(unstable=TRUE, example=FALSE, name="hostedplumber") do_deploy_api(drop, "append", "./inst/examples/01-append/", 8001) do_deploy_api(drop, "filters", "./inst/examples/02-filters/", 8002) # GitHub install_package_secure(drop, "digest") # devtools is the other dependency, but by unstable=TRUE on do_provision we already have that do_deploy_api(drop, "github", "./inst/examples/03-github/", 8003) # Sessions droplet_ssh(drop, 'R -e "install.packages(\\"PKI\\",,\\"https://www.rforge.net\\")"') do_deploy_api(drop, "sessions", "./inst/examples/06-sessions/", 8006, preflight="pr$addGlobalProcessor(plumber::sessionCookie('secret', 'cookieName', path='/'));") # Mailgun install_package_secure(drop, "htmltools") do_deploy_api(drop, "mailgun", "./inst/examples/07-mailgun/", 8007) # MANUAL: configure DNS, then # do_configure_https(drop, "plumber.tres.tl"... ) plumber/inst/rstudio/0000755000176200001440000000000013304040260014356 5ustar liggesusersplumber/inst/rstudio/templates/0000755000176200001440000000000013304040260016354 5ustar liggesusersplumber/inst/rstudio/templates/project/0000755000176200001440000000000013304040260020022 5ustar liggesusersplumber/inst/rstudio/templates/project/new-rstudio-project.dcf0000644000176200001440000000021213304040260024417 0ustar liggesusersTitle: New Plumber API Project Binding: newRStudioProject Subtitle: Create a new API using Plumber Icon: plumber.png OpenFiles: plumber.R plumber/inst/rstudio/templates/project/resources/0000755000176200001440000000000013304040260022034 5ustar liggesusersplumber/inst/rstudio/templates/project/resources/plumber.R0000644000176200001440000000136413304040260023631 0ustar liggesusers# # This is a Plumber API. In RStudio 1.2 or newer you can run the API by # clicking the 'Run API' button above. # # In RStudio 1.1 or older, see the Plumber documentation for details # on running the API. # # Find out more about building APIs with Plumber here: # # https://www.rplumber.io/ # library(plumber) #* @apiTitle Plumber Example API #* Echo back the input #* @param msg The message to echo #* @get /echo function(msg=""){ list(msg = paste0("The message is: '", msg, "'")) } #* Plot a histogram #* @png #* @get /plot function(){ rand <- rnorm(100) hist(rand) } #* Return the sum of two numbers #* @param a The first number to add #* @param b The second number to add #* @post /sum function(a, b){ as.numeric(a) + as.numeric(b) } plumber/inst/rstudio/templates/project/plumber.png0000644000176200001440000002121213304040260022174 0ustar liggesusersPNG  IHDRrdZRdbKGD pHYs  tIME:@ IDATxy|Tg=m&컈*k[⾿վ.ZEmݪhߺ[+U@ET@IlI2ϜsIX,Jg 9gs~9cI=?gN`0_3fސ-z'Vf٣ _o+=7WT8`Ѹ3|QQ)OO5Buل`P#JM]@K B P!,S\@Voك( iy-;d5=4b]U=mA @}khFQ _Tuk"S rc/g>Xp$b HeYt:.돧pSVW%BaR!DƗR֖7f)WQ{?4ͯ- S2(Z6}#@^YᦪVK,q0CϼtimI9ӈqg`4VYWYUE>B I#ń&IHHaulrqxw7%bKC\DC $)=,hv'jRWpH$jm% ŞM?䷷|U՞#-+ڜzIDh]/>f{r:mBARlȲ,{3S:5k/AcHJnMlAFPIosܗA.Tn> pQ$ Ie !,:+h TcI6$E#WW:`!wyjcѲ}yp`O9$/`uIjzV!7ݩ9q/ 7^`u>ˆG(1Eu"`H28ds'nTTK)y缫5ՕNEt$ K>s4 _ EX[>%P^dEŝC躎a#-# ɀ׷T2oϗ B`ۑe' ono 472RNձ.~l?1A _ CHX'˚~|Lfid-# N:.%pZ^}{ %;' UUӑH]בͫs%Ӱq<2ˑ(e;a k{"Zw݁l֪8<:!|2-w L&SlSi'?oS^ٌ!9B"I$D1R)IxL9n,}8idQZVBQClHJ:Q,Dyq"2gLDvW hF/o0o!s<u7m߼zL1Վj>nl*3e2sִxWoo&?)y'cw9=:rd$6ٛןFO[7~2H%,6TԲr&򽬫IOmxs[,\T+/>Ȁ>^0w6]$V5Iױ :݌ -g)ZƶUd:&8 J`:drԸgȜ5DVƃ =oQn(  ㈆1$zef7,1cmUr|GJC=zSRG´K~o|>SIwx򹿣fpzpvͅjs2rp.9y̺'\2vSMMdk@8'=@~g2Vl4֕sE"CIàjZa~?{vn/>ά4s~7\Ŗ"b{; Tw+e'Hs_anaYEX)'X8pl:j4y>/|;X<..xkcN.xZeJ\?gF}kgN2sT1=ssrFѲ-}z?<`Z 2Gg71ڂ+P^A~S)F +37l6WS%0h'&ّd[v<wܴR*HOOgҥo-^(`A3+3͟|(KI''+5 ׋1#Y_ߐ,)sm5L[{mi C pZ]}=ϟσ<ƪ*ꚚiiLsw!K%ZAF/~ ~hPlkn;#hM{%? &._1Gڴf׮תa{0]{Sy?+I{y31}XInw!GdeSR: .ى677?~-0ݺ{˲1c\RRrALR݇k+l\w, E~\{`.q)δ2Oq=´S08m˖.#6ჹVle5r]:%az_;-{ڹ7pɧA֭'IF}~*ɇ wy'/0 >>~ve:-)HfYEҦJLˢ 0cѢEydASSӘx< xzKSx%3OaQI]R4mH%im쿼m;_/2pf9Æݗ+lz[6EQxĐAҠ>\L>iCLlǑB|P%촉^# پ^oTHVUYۮp0\<tD;A|ѣGrYg5b۶f cnj?泷~úN:ߔd˲,Y%t|'>1˗+O8 ݆heZLUjR~x#23_}f:nNCCX ӲpTVnמNlzёȑo~m~;{PXpвbIa~˲.᩿- lRqXD)xNZvI' /l96 3l/  ذ!ym2lX֝YHjɤ? Di1ƍ@a~6zaT,\ nnl쫀\@1==y@]nW=|0RD"DQEyɘӰĭ7̔BvN&iO?g)2ɞwZ}$25_CQ^boI/-B|<5??i…y7RU]qGcc#T 4ho^|˖eYgN=z3A;rfQz-'8pޮJ&jݕfM oQ'{}k ;u9d^uh|w^! ث@G,,v;4(Y"{>w 'MO/?~<#G/.îil;4Bʙ=m_gOetx (_Q?uC}ScL2:rkPñ.“ӍM\"q|O$PSm򿿸hjxuFm КtP6X{N;= SH4VSmƪ3qұ3Pixٰ~5k֜`By_ bYVc(j8ٹ-I1y_ۙ6o}C]srnQ :bl*Ktw6'IKcKf۶R:_GsxM^ȒL%M"=;s@W..kW!&2S? u]_$,V!I~W/s+*+^_$u~&ץtft &fL᳏>)O$0fݿ7?<{i(>uks8Y4GFQ`~ >j,HL˶J F=Ԍ%޺mnMT<`N"/;֔gXFK4R}-{zE'^lvgW#̼b5aTgU*&,Bu4v(3@ȒD^ZT^jſ-A`iR]4? v( - 3 ~T*ҝ]~,$y&MDCxҳvvԉyٝ dX.,j$c}WqӃja>o񐒝T{5{TrEX{eUc)<ɝ8pV^֢lUnYG*uE:YiG8Ԋ˛;C$p4s^;;KgةW>e9݀֊ŔNQ@XUزrQlT/~ܲq,!? {?#*;؆۽[]o˿ThLqǧ=HG G "ݨ'"9P.l6 3l<NV&IHS<\|4P[`[;~)mUmR`ɠߛj .\S$1u1Cb$1RDGO" ewI@h߼'\I]f ?Щhv6, VO$PGatk:- "lAMZBfӧAدPl^Dc<һ =[Ɍ1ephȨ K0Ul$peUN"Jґrg$䕐d_D%qJH&|Yc?Ə&!W?K;f]:_A/k vD X,x L,}?{;u[\3#Yh vO$HÛC,Bk[z#hHo{*k?!+.EN<xȯ?+r6SWv1F*'HXfߙ $KgS$f釕dһzC>{\П_pGIKѽt0煷vՆr0CAy”>YEU+?IJg THPIHo[@{Pu3M߰[͑e\WZ).!WٵH^7w({;@СU U*sNE>dS)a:,K@(Ĕ V#4EuI Pd=\W5 ?,#Hô TErht\d:_J,c0,e2( ;p2H YuGA ZkȊҭ EQHs8H "H!=Ӈ'n#tLjfa2SUU%d ~Na#q\D8i0$cfJ Ly]kҧ~gd:j*&ܮWY™ٰ(FD$2>=Zu}z2N[s=K$2l6rѓ] UU;[=I0 큀ǫƞ@ʏzȃeHx0*́X4l0,#IvˍB:euϵ2. 1@]I),pp6ׯ  RaRHE`g6YWܫKYH󦣨6r{K?%Iu$Eٻȃco7d%DgezȲ?dfMdop$,2j!b#H@0i^jy9G !;](jcz% droplet_wait() # pl <- droplet(13426136) install <- function(droplet){ droplet %>% debian_add_swap() %>% install_new_r() %>% install_docker() %>% prepare_plumber() } install_docker <- function(droplet){ droplet %>% droplet_ssh(c("sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D", "echo 'deb https://apt.dockerproject.org/repo ubuntu-trusty main' > /etc/apt/sources.list.d/docker.list")) %>% debian_apt_get_update() %>% droplet_ssh("sudo apt-get install linux-image-extra-$(uname -r)") %>% debian_apt_get_install("docker-engine") %>% droplet_ssh(c("curl -L https://github.com/docker/compose/releases/download/1.7.0/docker-compose-`uname -s`-`uname -m` > /usr/local/bin/docker-compose", "chmod +x /usr/local/bin/docker-compose")) } install_new_r <- function(droplet){ droplet %>% droplet_ssh(c("echo 'deb https://cran.rstudio.com/bin/linux/ubuntu trusty/' >> /etc/apt/sources.list", "apt-key adv --keyserver keyserver.ubuntu.com --recv-keys E084DAB9")) %>% debian_apt_get_update() %>% debian_install_r() } prepare_plumber<- function(droplet){ droplet %>% droplet_ssh("git clone https://github.com/trestletech/plumber.git") %>% droplet_ssh("cd plumber/inst/hosted/ && docker-compose up -d --build") } # Update instructions for adding new images: # - Update the docker-compose config file to include the new service. Test locally # - Commit # docker pull trestle/plumber #AFTER build is complete. # git pull to get updates to docker-compose config # docker-compose build NEW_IMAGE # docker-compose up --no-deps -d NEW_IMAGE # - https://docs.docker.com/compose/production/ plumber/inst/hosted/nginx.conf0000644000176200001440000000202313304040260016142 0ustar liggesusersevents { worker_connections 4096; ## Default: 1024 } http { default_type application/octet-stream; sendfile on; tcp_nopush on; server_names_hash_bucket_size 128; # this seems to be required for some vhosts server { listen 80 default_server; listen [::]:80 default_server ipv6only=on; root /usr/share/nginx/html; index index.html index.htm; server_name rapier.tres.tl; server_name plumber.tres.tl; location /append/ { proxy_pass http://append:8000/; proxy_set_header Host $host; } location /filters/ { proxy_pass http://filters:8000/; proxy_set_header Host $host; } location /github/ { proxy_pass http://github:8000/; proxy_set_header Host $host; } location /sessions/ { proxy_pass http://sessions:8000/; proxy_set_header Host $host; } location /mailgun/ { proxy_pass http://mailgun:8000/; proxy_set_header Host $host; } #location /balanced/ { # proxy_pass http://lb/; # proxy_set_header Host $host; #} location ~ /\.ht { deny all; } } } plumber/inst/hosted/docker-compose.yml0000644000176200001440000000155113304040260017612 0ustar liggesusersversion: '2' services: append: image: trestletech/plumber command: '/examples/01-append/appender.R' volumes: - ../examples:/examples restart: always filters: image: trestletech/plumber command: '/examples/02-filters/filters.R' volumes: - ../examples:/examples restart: always github: build: ../examples/03-github/ volumes: - ../examples:/examples restart: always sessions: build: ../examples/06-sessions/ volumes: - ../examples:/examples restart: always mailgun: build: ../examples/07-mailgun/ volumes: - ../examples:/examples restart: always nginx: image: nginx:1.9 ports: - "80:80" volumes: - ./nginx.conf:/etc/nginx/nginx.conf:ro restart: always depends_on: - append - sessions - mailgun - filters - github plumber/tests/0000755000176200001440000000000013305322734013064 5ustar liggesusersplumber/tests/testthat.R0000644000176200001440000000007213304040260015034 0ustar liggesuserslibrary(testthat) library(plumber) test_check("plumber") plumber/tests/testthat/0000755000176200001440000000000013305412327014722 5ustar liggesusersplumber/tests/testthat/test-injection.R0000644000176200001440000000036013304040260017773 0ustar liggesuserscontext("Injection") test_that("Injected arguments on req$args get passed on.", { r <- plumber$new("files/filter-inject.R") res <- PlumberResponse$new() expect_equal(r$serve(make_req("GET", "/"), res)$body, jsonlite::toJSON(13)) }) plumber/tests/testthat/test-find-port.R0000644000176200001440000000213013304040260017710 0ustar liggesuserscontext("find port") test_that("ports can be randomly found", { foundPorts <- NULL for (i in 1:50){ p <- getRandomPort() expect_gte(p, 3000) expect_lte(p, 10000) foundPorts <- c(foundPorts, p) } # It's possible we got a collision or two, but shouldn't have many. expect_gt(length(unique(foundPorts)), 45) }) test_that("global port used if available", { .globals$port <- 1234 expect_equal(findPort(), 1234) rm("port", envir = .globals) }) test_that("finds a good port and persists it", { testthat::skip_on_cran() p <- findPort() # Persisted expect_equal(.globals$port, p) # Check that we can actually start a server srv <- httpuv::startServer("127.0.0.1", p, list()) # Cleanup rm("port", envir = .globals) httpuv::stopServer(srv) }) test_that("we don't pin to globals$port if it's occupied", { testthat::skip_on_cran() srv <- httpuv::startServer("127.0.0.1", 1234, list()) .globals$port <- 1234 p <- findPort() # It should shuffle to find another port. expect_true(p != 1234) rm("port", envir = .globals) httpuv::stopServer(srv) }) plumber/tests/testthat/test-postbody.R0000644000176200001440000000166213305305241017666 0ustar liggesuserscontext("POST body") test_that("JSON is consumed on POST", { expect_equal(parseBody('{"a":"1"}'), list(a = "1")) }) test_that("Query strings on post are handled correctly", { expect_equivalent(parseBody("a="), list()) # It's technically a named list() expect_equal(parseBody("a=1&b=&c&d=1"), list(a="1", d="1")) }) test_that("Able to handle UTF-8", { expect_equal(parseBody('{"text":"élise"}', "UTF-8")$text, "élise") }) test_that("filter passes on charset", { charset_passed <- "" req <- list( .internal = list(postBodyHandled = FALSE), rook.input = list( read_lines = function() { called <- TRUE return("this is a body") } ), HTTP_CONTENT_TYPE = "text/html; charset=testset", args = c() ) with_mock( parseBody = function(body, charset = "UTF-8") { print(charset) body }, expect_output(postBodyFilter(req), "testset"), .env = "plumber" ) }) plumber/tests/testthat/test-filters.R0000644000176200001440000000527713304040260017475 0ustar liggesuserscontext("filters") test_that("Filters work", { r <- plumber$new("files/filters.R") expect_equal(length(r$filters), 4+2) #4 for post, query string, cookie, and shared secret filters expect_equal(r$filters[[5]]$name, "something") expect_equal(r$filters[[6]]$name, "nospace") }) test_that("Filters can update req$args", { r <- plumber$new("files/filters.R") req <- make_req("GET", "/") res <- PlumberResponse$new() expect_equal(r$serve(req, res)$body, jsonlite::toJSON(23)) }) test_that("Redundant filters fail", { expect_error(plumber$new("files/filter-redundant.R"), regexp="Multiple @filters") }) test_that("Empty filters fail", { expect_error(plumber$new("files/filter-empty.R"), regexp="No @filter name specified") }) test_that("Filter and path fails", { expect_error(plumber$new("files/filterpath.R"), regexp="can only be") }) test_that("Filter and assets fails", { expect_error(plumber$new("files/filterasset.R"), regexp="can only be") }) test_that("Terminal filters indeed terminate", { res <- PlumberResponse$new() r <- plumber$new("files/terminal-filter.R") expect_equal(r$route(make_req("GET", "/"), res), 1) }) test_that("complete addFilter works", { r <- plumber$new() serializer <- "ser" name <- "fullFilter" expr <- expression(function(req, res){res$setHeader("expr", TRUE)}) baseFilters <- length(r$filters) r$filter(name, expr, serializer) expect_equal(length(r$filters), baseFilters+1) fil <- r$filters[[baseFilters+1]] expect_equal(fil$name, "fullFilter") expect_equal(fil$lines, NA) expect_equal(fil$serializer, serializer) res <- PlumberResponse$new() req <- list() fil$exec(req=req, res=res) h <- res$headers expect_true(h$expr) }) # No processors or serializer test_that("sparse addFilter works", { r <- plumber$new() name <- "sparseFilter" expr <- expression(function(req, res){res$setHeader("expr", TRUE)}) baseFilters <- length(r$filters) r$filter(name, expr) expect_equal(length(r$filters), baseFilters+1) fil <- r$filters[[baseFilters+1]] expect_equal(fil$name, "sparseFilter") expect_equal(fil$lines, NA) res <- PlumberResponse$new() req <- list() fil$exec(req=req, res=res) h <- res$headers expect_true(h$expr) }) test_that("sparse addFilter with a function works", { r <- plumber$new() name <- "sparseFilter" expr <- function(req, res){res$setHeader("expr", TRUE)} baseFilters <- length(r$filters) r$filter(name, expr) expect_equal(length(r$filters), baseFilters+1) fil <- r$filters[[baseFilters+1]] expect_equal(fil$name, "sparseFilter") expect_equal(fil$lines, NA) res <- PlumberResponse$new() req <- list() fil$exec(req=req, res=res) h <- res$headers expect_true(h$expr) }) plumber/tests/testthat/test-plumber.R0000644000176200001440000003722213305330163017473 0ustar liggesuserscontext("Plumber") test_that("Endpoints are properly identified", { r <- plumber$new("files/endpoints.R") expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 5) expect_equal(r$endpoints[[1]][[1]]$exec(), 5) expect_equal(r$endpoints[[1]][[2]]$exec(), 5) expect_equal(r$endpoints[[1]][[3]]$exec(), 10) expect_equal(r$endpoints[[1]][[4]]$exec(), 12) expect_equal(r$endpoints[[1]][[5]]$exec(), 14) }) test_that("Empty file is OK", { r <- plumber$new() expect_equal(length(r$endpoints), 0) }) test_that("The file is sourced in the envir", { r <- plumber$new("files/in-env.R") expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 2) expect_equal(r$endpoints[[1]][[1]]$exec(), 15) }) test_that("Verbs translate correctly", { r <- plumber$new("files/verbs.R") expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 10) expect_equal(r$endpoints[[1]][[1]]$verbs, c("GET", "PUT", "POST", "DELETE", "HEAD", "OPTIONS", "PATCH")) expect_equal(r$endpoints[[1]][[2]]$verbs, "GET") expect_equal(r$endpoints[[1]][[3]]$verbs, "PUT") expect_equal(r$endpoints[[1]][[4]]$verbs, "POST") expect_equal(r$endpoints[[1]][[5]]$verbs, "DELETE") expect_equal(r$endpoints[[1]][[6]]$verbs, "POST") expect_equal(r$endpoints[[1]][[7]]$verbs, "GET") expect_equal(r$endpoints[[1]][[8]]$verbs, "HEAD") expect_equal(r$endpoints[[1]][[9]]$verbs, "OPTIONS") expect_equal(r$endpoints[[1]][[10]]$verbs, "PATCH") }) test_that("Invalid file fails gracefully", { expect_error(plumber$new("asdfsadf"), regexp="File does not exist.*asdfsadf") }) test_that("plumb accepts a file", { r <- plumb("files/endpoints.R") expect_length(r$endpoints[[1]], 5) }) test_that("plumb gives a good error when passing in a dir instead of a file", { if (identical( tolower(Sys.info()[["sysname"]]), "windows" )) { # https://stat.ethz.ch/R-manual/R-devel/library/base/html/files.html # "However, directory names must not include a trailing backslash or slash on Windows" expect_error(plumb("files/"), "File does not exist:") } else { expect_error(plumb("files/"), "Expecting a file but found a directory: 'files/'") } }) test_that("plumb accepts a directory with a `plumber.R` file", { # works without trailing slash r <- plumb(dir = 'files') expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 5) # works with trailing slash r <- plumb(dir = 'files/') expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 5) # errors when no plumber.R found expect_error(plumb(dir = 'files/static'), regexp="No plumber.R file found in the specified directory: files/static") # errors when neither dir is empty and file is not given expect_error(plumb(dir=""), regexp="You must specify either a file or directory*") # reads from working dir if no args expect_error(plumb(), regexp="No plumber.R file found in the specified directory: .") # errors when both dir and file are given expect_error(plumb(file="files/endpoints.R", dir="files"), regexp="You must set either the file or the directory parameter, not both") }) test_that("plumb() a dir leverages `entrypoint.R`", { expect_null(plumber:::.globals$serializers$fake, "This just that your Plumber environment is dirty. Restart your R session.") r <- plumb(dir = 'files/entrypoint/') expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 1) # A global serializer was added by entrypoint.R before parsing expect_true(!is.null(plumber:::.globals$serializers$fake)) # Clean up after ourselves gl <- plumber:::.globals gl$serializers["fake"] <- NULL }) test_that("bad `entrypoint.R`s throw", { expect_error(plumb(dir = 'files/entrypoint-bad/'), "runnable Plumber router") }) test_that("Empty endpoints error", { expect_error(plumber$new("files/endpoints-empty.R"), regexp="No path specified") }) test_that("The old roxygen-style comments work", { r <- plumber$new("files/endpoints-old.R") expect_equal(length(r$endpoints), 1) expect_equal(length(r$endpoints[[1]]), 5) expect_equal(r$endpoints[[1]][[1]]$exec(), 5) expect_equal(r$endpoints[[1]][[2]]$exec(), 5) expect_equal(r$endpoints[[1]][[3]]$exec(), 10) expect_equal(r$endpoints[[1]][[4]]$exec(), 12) expect_equal(r$endpoints[[1]][[5]]$exec(), 14) }) test_that("routes can be constructed correctly", { pr <- plumber$new() pr$handle("GET", "/nested/path/here", function(){}) pr$handle("POST", "/nested/path/here", function(){}) pr2 <- plumber$new() pr2$handle("POST", "/something", function(){}) pr2$handle("GET", "/", function(){}) pr$mount("/mysubpath", pr2) stat <- PlumberStatic$new(".") pr$mount("/static", stat) expect_length(pr$routes, 3) expect_true("plumberstatic" %in% class(pr$routes[["static"]])) expect_true("plumber" %in% class(pr$routes[["mysubpath"]])) # 2 endpoints at the same location (different verbs) expect_length(pr$routes$nested$path$here, 2) }) test_that("mounts can be read correctly", { pr <- plumber$new() pr$handle("GET", "/nested/path/here", function(){}) pr$handle("POST", "/nested/path/here", function(){}) pr2 <- plumber$new() pr2$handle("POST", "/something", function(){}) pr2$handle("GET", "/", function(){}) pr$mount("/mysubpath", pr2) stat <- PlumberStatic$new(".") pr$mount("/static", stat) expect_length(pr$routes, 3) expect_true("plumberstatic" %in% class(pr$mounts[["/static/"]])) expect_true("plumber" %in% class(pr$mounts[["/mysubpath/"]])) }) test_that("prints correctly", { skip_on_cran() pr <- plumber$new() pr$handle("GET", "/nested/path/here", function(){}) pr$handle("POST", "/nested/path/here", function(){}) pr2 <- plumber$new() pr2$handle("POST", "/something", function(){}) pr2$handle("GET", "/", function(){}) pr$mount("/mysubpath", pr2) stat <- PlumberStatic$new(".") pr$mount("/static", stat) printed <- capture.output(print(pr)) regexps <- c( "Plumber router with 2 endpoints, 4 filters, and 2 sub-routers", "Call run\\(\\) on this object", "├──\\[queryString\\]", "├──\\[postBody\\]", "├──\\[cookieParser\\]", "├──\\[sharedSecret\\]", "├──/nested", "│ ├──/path", "│ │ └──/here \\(GET, POST\\)", "├──/mysubpath", "│ │ # Plumber router with 2 endpoints, 4 filters, and 0 sub-routers.", "│ ├──\\[queryString\\]", "│ ├──\\[postBody\\]", "│ ├──\\[cookieParser\\]", "│ ├──\\[sharedSecret\\]", "│ ├──/something \\(POST\\)", "│ └──/ \\(GET\\)", "├──/static", "│ │ # Plumber static router serving from directory: \\." ) for (i in 1:length(regexps)){ expect_match(printed[i], regexps[i], info=paste0("on line ", i)) } }) test_that("mounts work", { pr <- plumber$new() sub <- plumber$new() sub$handle("GET", "/", function(){ 1 }) sub$handle("GET", "/nested/path", function(a){ a }) pr$mount("/subpath", sub) res <- PlumberResponse$new() pr$route(make_req("GET", "/nested/path"), res) expect_equal(res$status, 404) val <- pr$route(make_req("GET", "/subpath/nested/path", qs="?a=123"), PlumberResponse$new()) expect_equal(val, "123") val <- pr$route(make_req("GET", "/subpath/nested/path", body='{"a":123}'), PlumberResponse$new()) expect_equal(val, 123) val <- pr$route(make_req("GET", "/subpath/"), PlumberResponse$new()) expect_equal(val, 1) }) test_that("mounting at root path works", { pr <- plumber$new() sub <- plumber$new() sub$handle("GET", "/", function(){ 1 }) sub$handle("GET", "/nested/path", function(){ 2 }) pr$mount("/", sub) val <- pr$route(make_req("GET", "/nested/path"), PlumberResponse$new()) expect_equal(val, 2) val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_equal(val, 1) }) test_that("conflicting mounts behave consistently", { pr <- plumber$new() sub <- plumber$new() sub$handle("GET", "/", function(){ 1 }) pr$mount("/subpath", sub) val <- pr$route(make_req("GET", "/subpath/"), PlumberResponse$new()) expect_equal(val, 1) pr$handle("GET", "/subpath/", function(){ 2 }) val <- pr$route(make_req("GET", "/subpath/"), PlumberResponse$new()) expect_equal(val, 2) }) test_that("hooks can be registered", { pr <- plumber$new() events <- NULL pr$handle("GET", "/", function(){ events <<- c(events, "exec") }) pr$registerHook("preroute", function(){ events <<- c(events, "preroute") }) pr$registerHook("postroute", function(){ events <<- c(events, "postroute") }) pr$registerHook("preserialize", function(){ events <<- c(events, "preserialize") }) pr$registerHook("postserialize", function(){ events <<- c(events, "postserialize") }) pr$serve(make_req("GET", "/"), PlumberResponse$new()) expect_equal(events, c("preroute", "exec", "postroute", "preserialize", "postserialize")) }) test_that("preroute hook gets the right data", { pr <- plumber$new() pr$handle("GET", "/", function(){ }) rqst <- make_req("GET", "/") pr$registerHook("preroute", function(data, req, res){ expect_true("PlumberResponse" %in% class(res)) expect_equal(rqst, req) expect_true(is.environment(data)) }) pr$serve(rqst, PlumberResponse$new()) }) test_that("postroute hook gets the right data and can modify", { pr <- plumber$new() pr$handle("GET", "/abc", function(){ 123 }) pr$registerHook("postroute", function(data, req, res, value){ expect_true("PlumberResponse" %in% class(res)) expect_equal(req$PATH_INFO, "/abc") expect_true(is.environment(data)) expect_equal(value, 123) "new val" }) res <- pr$serve(make_req("GET", "/abc"), PlumberResponse$new()) expect_equal(as.character(res$body), '["new val"]') }) test_that("preserialize hook gets the right data and can modify", { pr <- plumber$new() pr$handle("GET", "/abc", function(){ 123 }) pr$registerHook("preserialize", function(data, req, res, value){ expect_true("PlumberResponse" %in% class(res)) expect_equal(req$PATH_INFO, "/abc") expect_true(is.environment(data)) expect_equal(value, 123) "new val" }) res <- pr$serve(make_req("GET", "/abc"), PlumberResponse$new()) expect_equal(as.character(res$body), '["new val"]') }) test_that("postserialize hook gets the right data and can modify", { pr <- plumber$new() pr$handle("GET", "/abc", function(){ 123 }) pr$registerHook("postserialize", function(data, req, res, value){ expect_true("PlumberResponse" %in% class(res)) expect_equal(req$PATH_INFO, "/abc") expect_true(is.environment(data)) expect_equal(as.character(value$body), "[123]") value$body <- "new val" value }) res <- pr$serve(make_req("GET", "/abc"), PlumberResponse$new()) expect_equal(as.character(res$body), 'new val') }) test_that("invalid hooks err", { pr <- plumber$new() expect_error(pr$registerHook("flargdarg")) }) test_that("handle invokes correctly", { pr <- plumber$new() pr$handle("GET", "/trailslash", function(){ "getter" }) pr$handle("POST", "/trailslash/", function(){ "poster" }) expect_equal(pr$route(make_req("GET", "/trailslash"), PlumberResponse$new()), "getter") res <- PlumberResponse$new() pr$route(make_req("GET", "/trailslash/"), res) # With trailing slash expect_equal(res$status, 404) res <- PlumberResponse$new() pr$route(make_req("POST", "/trailslash"), res) # Wrong verb expect_equal(res$status, 404) expect_equal(pr$route(make_req("POST", "/trailslash/"), PlumberResponse$new()), "poster") res <- PlumberResponse$new() pr$route(make_req("POST", "/trailslash"), res) # w/o trailing slash expect_equal(res$status, 404) res <- PlumberResponse$new() pr$route(make_req("GET", "/trailslash/"), res) # Wrong verb expect_equal(res$status, 404) }) test_that("handle with an endpoint works", { pr <- plumber$new() ep <- PlumberEndpoint$new("GET", "/", function(){ "manual endpoint" }, pr$environment, serializer_json()) pr$handle(endpoint=ep) val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_equal(val, "manual endpoint") }) test_that("handle with and enpoint and endpoint def fails", { pr <- plumber$new() ep <- PlumberEndpoint$new("GET", "/", function(){ "manual endpoint" }, pr$environment, serializer_json()) expect_error(pr$handle("GET", "/", endpoint=ep)) }) test_that("full handle call works", { pr <- plumber$new() pr$filter("f1", function(req){ req$filtered <- TRUE; forward() }) pr$handle("GET", "/preempt", function(req){ expect_null(req$filtered) "preempted" }, "f1", serializer_unboxed_json()) pr$handle("GET", "/dontpreempt", function(req){ expect_true(req$filtered) "unpreempted" }, serializer=serializer_unboxed_json()) res <- PlumberResponse$new() val <- pr$route(make_req("GET", "/preempt"), res) expect_equal(val, "preempted") # no JSON box res <- PlumberResponse$new() val <- pr$route(make_req("GET", "/dontpreempt"), res) expect_equal(val, "unpreempted") # no JSON box }) test_that("Expressions and functions both work on handle", function(){ pr <- plumber$new() pr$handle("GET", "/function", function(req){ req[["PATH_INFO"]] }) pr$handle("GET", "/expression", expression(function(req){ req[["PATH_INFO"]] })) val <- pr$route(make_req("GET", "/function"), PlumberResponse$new()) expect_equal(val, "/function") val <- pr$route(make_req("GET", "/expression"), PlumberResponse$new()) expect_equal(val, "/expression") }) test_that("Expressions and functions both work on filter", function(){ pr <- plumber$new() pr$filter("ff", function(req){ req$filteredF <- TRUE; forward() }) pr$filter("fe", expression(function(req){ req$filteredE <- TRUE; forward() })) pr$handle("GET", "/", function(req){ req$filteredE && req$filteredF }) val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_true(val) pr$handle("GET", "/expr", expression(function(req){ req$filteredE && req$filteredF })) val <- pr$route(make_req("GET", "/expr"), PlumberResponse$new()) expect_true(val) }) test_that("filters and endpoint expressions evaluated in the appropriate (possibly injected) environment", function(){ # Create an environment that contains a variable named `y`. env <- new.env(parent=.GlobalEnv) env$y <- 10 # We provide expressions so that they get closurified in the right environment # and will be able to find `y`. # This would all fail without an injected environment that contains `y`. pr <- plumber$new(envir=env) pr$filter("ff", expression(function(req){ req$ys <- y^2; forward() })) pr$handle("GET", "/", expression(function(req){ paste(y, req$ys) })) # Send a request through and we should see an assign to our env. val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_equal(val, "10 100") }) test_that("filters and endpoints executed in the appropriate environment", function(){ # We've already seen that, if expressions, they're going to be evaluated in the # appropriate environment, but we can also confirm that once they've been evaluated, # they're then executed in the appropriate environment. # This almost certainly doesn't matter unless a function is inspecting the call stack, # but for the sake of consistency we not only ensure that any given expressions are # evaluated in the appropriate environment, but also that they are then called in the # given environment, as well. env <- new.env(parent=.GlobalEnv) pr <- plumber$new(envir=env) pr$filter("ff", expression(function(req){ req$filterEnv <- parent.frame(); forward() })) pr$handle("GET", "/", expression(function(req){ expect_identical(req$filterEnv, parent.frame()) parent.frame() })) # Send a request through and we should see an assign to our env. val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_identical(env, val) }) plumber/tests/testthat/test-sessions.R0000644000176200001440000000405213304040260017661 0ustar liggesuserscontext("Sessions") make_req_cookie <- function(verb, path, cookie){ req <- new.env() req$REQUEST_METHOD <- toupper(verb) req$PATH_INFO <- path req$rook.input <- list(read_lines = function(){ "" }) if (!missing(cookie)){ req$HTTP_COOKIE <- cookie } req } test_that("cookies are set", { r <- plumber$new() expr <- expression(function(req, res){ req$session <- list(abc=123); TRUE }) r$handle("GET", "/", expr) sc <- sessionCookie("mysecret", name="plcook") r$registerHooks(sc) res <- PlumberResponse$new() r$serve(make_req_cookie("GET", "/"), res) key <- PKI::PKI.digest(charToRaw("mysecret"), "SHA256") cook <- res$headers[["Set-Cookie"]] expect_match(cook, "^plcook") cook <- gsub("^plcook=", "", cook, perl=TRUE) de <- PKI::PKI.decrypt(base64enc::base64decode(cook), key, "aes256") expect_equal(rawToChar(de), '{"abc":[123]}') }) test_that("cookies are read", { r <- plumber$new() expr <- expression(function(req, res){ req$session$abc }) r$handle("GET", "/", expr) sc <- sessionCookie("mysecret", name="plcook") r$registerHooks(sc) res <- PlumberResponse$new() # Create the request with an encrypted cookie key <- PKI::PKI.digest(charToRaw("mysecret"), "SHA256") data <- '{"abc":[123]}' enc <- PKI::PKI.encrypt(charToRaw(data), key, "aes256") r$serve(make_req_cookie("GET", "/", paste0('plcook=', base64enc::base64encode(enc))), res) expect_equal(res$body, jsonlite::toJSON(123)) }) test_that("invalid cookies/JSON are handled", { r <- plumber$new() expr <- expression(function(req, res){ ifelse(is.null(req$session), "NULL", req$session) }) r$handle("GET", "/", expr) sc <- sessionCookie("mysecret", name="plcook") r$registerHooks(sc) res <- PlumberResponse$new() key <- PKI::PKI.digest(charToRaw("thewrongkey"), "SHA256") data <- '{"abc":[123]}' enc <- PKI::PKI.encrypt(charToRaw(data), key, "aes256") expect_warning({ r$serve(make_req_cookie("GET", "/", paste0('plcook=', base64enc::base64encode(enc))), res) }) expect_equal(res$body, jsonlite::toJSON("NULL")) }) plumber/tests/testthat/test-routing.R0000644000176200001440000000220313304040260017476 0ustar liggesuserscontext("Routing") test_that("Routing to errors and 404s works", { r <- plumber$new("files/router.R") errors <- 0 notFounds <- 0 errRes <- list(a=1) notFoundRes <- list(b=2) r$setErrorHandler(function(req, res, err){ errors <<- errors + 1; errRes }) r$set404Handler(function(req, res){ notFounds <<- notFounds + 1; notFoundRes }) res <- PlumberResponse$new() expect_equal(r$route(make_req("GET", "/"), res), "first") expect_equal(r$route(make_req("GET", "/abc"), res), "abc get") expect_equal(r$route(make_req("GET", "/dog"), res), "dog get") expect_equal(r$route(make_req("POST", "/dog"), res), "dog use") expect_equal(r$route(make_req("GET", "/path1"), res), "dual path") expect_equal(r$route(make_req("GET", "/path2"), res), "dual path") expect_equal(errors, 0) expect_equal(notFounds, 0) nf <- r$route(make_req("GET", "/something-crazy"), res) expect_equal(res$serializer, serializer_json()) expect_equal(nf, notFoundRes) expect_equal(notFounds, 1) er <- r$route(make_req("GET", "/error"), res) expect_equal(res$serializer, serializer_json()) expect_equal(er, errRes) expect_equal(errors, 1) }) plumber/tests/testthat/test-deprecated.R0000644000176200001440000000203313304040260020110 0ustar liggesuserscontext("Deprecated") test_that("addEndpoint continues to work", { pr <- plumber$new() expect_warning(pr$addEndpoint("GET", "/", function(){ 123 })) expect_error(expect_warning(pr$addEndpoint("GET", "/", function(){ 123 }, comments="break"))) val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_equal(val, 123) }) test_that("addFilter continues to work", { pr <- plumber$new() expect_warning(pr$addFilter("f1", function(req){ req$filtered <- TRUE })) pr$handle("GET", "/", function(req){ req$filtered }) val <- pr$route(make_req("GET", "/"), PlumberResponse$new()) expect_true(val) }) test_that("addGlobalProcessor continues to work", { pr <- plumber$new() expect_warning(pr$addGlobalProcessor(sessionCookie("secret", "cookieName"))) }) test_that("addAssets continues to work", { pr <- plumber$new() expect_warning(pr$addAssets("./files/static", "/public")) res <- PlumberResponse$new() val <- pr$route(make_req("GET", "/public/test.txt"), res) expect_true(inherits(val, "PlumberResponse")) }) plumber/tests/testthat/test-content-type.R0000644000176200001440000000210113305305241020441 0ustar liggesuserscontext("Content Types") test_that("contentType serializes properly", { l <- list(a=1, b=2, c="hi") val <- serializer_content_type("somethinghere")(l, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$headers$`Content-Type`, "somethinghere") expect_equal(val$body, l) }) test_that("empty contentType errors", { expect_error(serializer_content_type()) }) test_that("contentType works in files", { res <- PlumberResponse$new() r <- plumber$new("files/content-type.R") val <- r$serve(make_req("GET", "/"), res) expect_equal(val$headers$`Content-Type`, "text/plain") }) test_that("Parses charset properly", { charset <- getCharacterSet("Content-Type: text/html; charset=latin1") expect_equal(charset, "latin1") charset <- getCharacterSet("Content-Type: text/html; charset=greek8") expect_equal(charset, "greek8") }) test_that("Defaults charset when not there", { charset <- getCharacterSet("Content-Type: text/html") expect_equal(charset, "UTF-8") charset <- getCharacterSet(NULL) expect_equal(charset, "UTF-8") }) plumber/tests/testthat/test-warnings.R0000644000176200001440000000053313304040260017643 0ustar liggesuserscontext("Warnings") test_that("Routing to errors and 404s works", { r <- plumber$new("files/warn.R") res <- plumber:::PlumberResponse$new("json") expect_equal(options("warn")[[1]], 0) expect_warning(r$route(make_req("GET", "/warning"), res), "this is a warning") expect_equal(res$status, 1) expect_equal(options("warn")[[1]], 0) }) plumber/tests/testthat/test-endpoint.R0000644000176200001440000000436213304040260017637 0ustar liggesuserscontext("Endpoints") test_that("Endpoints execute in their environment", { env <- new.env() assign("a", 5, envir=env) foo <- parse(text="foo <- function(){ a }") r <- PlumberEndpoint$new('verb', 'path', foo, env, 1:2) expect_equal(r$exec(), 5) }) test_that("Missing lines are ok", { PlumberEndpoint$new('verb', 'path', { 1 }, environment()) }) test_that("Endpoints are exec'able with named arguments.", { foo <- parse(text="foo <- function(x){ x + 1 }") r <- PlumberEndpoint$new('verb', 'path', foo, environment()) expect_equal(r$exec(x=3), 4) }) test_that("Unnamed arguments error", { foo <- parse(text="foo <- function(){ 1 }") r <- PlumberEndpoint$new('verb', 'path', foo, environment()) expect_error(r$exec(3)) foo <- parse(text="foo <- function(x, ...){ x + 1 }") r <- PlumberEndpoint$new('verb', 'path', foo, environment()) expect_error(r$exec(x=1, 3)) }) test_that("Ellipses allow any named args through", { foo <- parse(text="function(...){ sum(unlist(list(...))) }") r <- PlumberEndpoint$new('verb', 'path', foo, environment()) expect_equal(r$exec(a=1, b=2, c=3), 6) foo <- parse(text="function(...){ list(...) }") r <- PlumberEndpoint$new('verb', 'path', foo, environment()) expect_equal(r$exec(a="aa", b="ba"), list(a="aa", b="ba")) }) test_that("Programmatic endpoints work", { r <- plumber$new() serializer <- "ser" expr <- expression(function(req, res){res$setHeader("expr", TRUE)}) r$handle("GET", "/", expr, "queryString", serializer) expect_equal(length(r$endpoints), 1) end <- r$endpoints[[1]][[1]] expect_equal(end$verbs, "GET") expect_equal(end$path, "/") expect_equal(names(r$endpoints)[1], "queryString") expect_equal(end$serializer, serializer) res <- PlumberResponse$new() req <- list() end$exec(req=req, res=res) h <- res$headers expect_true(h$expr) }) test_that("Programmatic endpoints with functions work", { r <- plumber$new() expr <- function(req, res){res$setHeader("expr", TRUE)} r$handle("GET", "/", expr) expect_equal(length(r$endpoints), 1) end <- r$endpoints[[1]][[1]] expect_equal(end$verbs, "GET") expect_equal(end$path, "/") res <- PlumberResponse$new() req <- list() end$exec(req=req, res=res) h <- res$headers expect_true(h$expr) }) plumber/tests/testthat/test-hookable.R0000644000176200001440000000544713304040260017610 0ustar liggesuserscontext("hookable") test_that("simple extension works", { simpleHook <- R6Class( "simplehook", inherit = hookable, public = list( exercise = function(hookName, args){ private$runHooks(hookName, args) } ) ) events <- NULL s <- simpleHook$new() s$registerHook("abcd", function(arg1){ events <<- c(events, arg1) }) s$registerHook("defg", function(arg2){ events <<- c(events, arg2) }) expect_null(events) s$exercise("abcd", list(arg1="arg1here", unused="test")) expect_equal(events, "arg1here") s$exercise("defg", list(arg2="arg2here")) expect_equal(events, c("arg1here", "arg2here")) }) test_that("registerHooks works", { simpleHook <- R6Class( "simplehook", inherit = hookable, public = list( exercise = function(hookName, args){ private$runHooks(hookName, args) } ) ) events <- NULL s <- simpleHook$new() s$registerHooks(list( defg = function(arg2){ events <<- c(events, arg2) }, abcd = function(arg1){ events <<- c(events, arg1) })) expect_null(events) s$exercise("abcd", list(arg1="arg1here", unused="test")) expect_equal(events, "arg1here") s$exercise("defg", list(arg2="arg2here")) expect_equal(events, c("arg1here", "arg2here")) }) test_that("overloading extension works", { simpleHook <- R6Class( "simplehook", inherit = hookable, public = list( registerHook = function(hook=c("hook1", "hook2"), fun){ hook <- match.arg(hook) super$registerHook(hook, fun) }, exercise = function(hookName, args){ private$runHooks(hookName, args) } ) ) s <- simpleHook$new() expect_error(s$registerHook("abcd", function(arg1){ events <<- c(events, arg1) }) ) events <- NULL s$registerHook("hook2", function(){ events <<- c(events, "hook2!") }) expect_null(events) # Works with missing args s$exercise("hook2") expect_equal(events, "hook2!") }) test_that("value forwarding works across stacked hooks", { simpleHook <- R6Class( "simplehook", inherit = hookable, public = list( exercise = function(hookName, args){ private$runHooks(hookName, args) } ) ) increment <- function(value){ value + 1 } s <- simpleHook$new() s$registerHook("valForward", increment) # Register the same hook twice. Should see the value increment by two each call since the # values are getting forwarded from the first hook into the second. s$registerHook("valForward", increment) s$registerHook("noVal", function(){ # Doesn't take a value parameter, so shouldn't be treated specially for value handling. return(3) }) v <- s$exercise("valForward", list(value=0)) expect_equal(v, 2) v <- s$exercise("noVal", list(value=0)) expect_equal(v, 0) }) plumber/tests/testthat/test-enumerate.R0000644000176200001440000000050213304040260017774 0ustar liggesuserscontext("Verb enumeration") test_that("enumerate returns all on 'use'", { expect_equal(enumerateVerbs("use"), c("GET", "PUT", "POST", "DELETE", "HEAD", "OPTIONS", "PATCH")) }) test_that("regular verbs return themselves", { expect_equal(enumerateVerbs("get"), "GET") expect_equal(enumerateVerbs("post"), "POST") }) plumber/tests/testthat/test-path-subst.R0000644000176200001440000000666413304040260020120 0ustar liggesuserscontext("Paths") test_that("paths are properly converted", { varRegex <- "([^/]+)" p <- createPathRegex("/car/") expect_equal(p$names, character()) expect_equal(p$regex, "^/car/$") p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", varRegex, "$")) p <- createPathRegex("/car//sell") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", varRegex, "/sell$")) p <- createPathRegex("/car//sell/") expect_equal(p$names, c("id", "price")) expect_equal(p$regex, paste0("^/car/", varRegex, "/sell/", varRegex, "$")) }) test_that("variables are typed", { p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d*\\.?\\d+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "(-?\\d*\\.?\\d+)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "([01tfTF]|true|false|TRUE|FALSE)", "$")) p <- createPathRegex("/car/") expect_equal(p$names, "id") expect_equal(p$regex, paste0("^/car/", "([01tfTF]|true|false|TRUE|FALSE)", "$")) }) test_that("path regex's are created properly", { expect_equivalent(extractPathParams(createPathRegex("/car/"), "/car/"), list()) expect_equal(extractPathParams(createPathRegex("/car/"), "/car/15"), list(id="15") ) expect_equal(extractPathParams(createPathRegex("/car//sell"), "/car/12/sell"), list(id="12") ) expect_equal(extractPathParams(createPathRegex("/car//sell/"), "/car/15/sell/$15,000"), list(id="15", price="$15,000")) }) test_that("integration of path parsing works", { r <- plumber$new("files/path-params.R") expect_equal(r$route(make_req("GET", "/car/13"), PlumberResponse$new()), "13") expect_equal(r$route(make_req("GET", "/car/int/13"), PlumberResponse$new()), 13) expect_equal(r$route(make_req("GET", "/car/int/-13"), PlumberResponse$new()), -13) expect_equal(r$route(make_req("GET", "/car/15/sell/$15,000"), PlumberResponse$new()), list(id="15", price="$15,000")) expect_equal(r$route(make_req("POST", "/car/13"), PlumberResponse$new()), "13") expect_equal(r$route(make_req("GET", "/car/15/buy/$15,000"), PlumberResponse$new()), list(id=15, price="$15,000")) expect_equal(r$route(make_req("GET", "/car/15/buy/$15,000.99"), PlumberResponse$new()), list(id=15, price="$15,000.99")) expect_equal(r$route(make_req("GET", "/car/ratio/1.5"), PlumberResponse$new()), 1.5) expect_equal(r$route(make_req("GET", "/car/ratio/-1.5"), PlumberResponse$new()), -1.5) expect_equal(r$route(make_req("GET", "/car/ratio/-.5"), PlumberResponse$new()), -.5) expect_equal(r$route(make_req("GET", "/car/ratio/.5"), PlumberResponse$new()), .5) expect_equal(r$route(make_req("GET", "/car/ratio/a"), PlumberResponse$new()), list(error = "404 - Resource Not Found")) expect_equal(r$route(make_req("GET", "/car/ratio/"), PlumberResponse$new()), list(error = "404 - Resource Not Found")) expect_equal(r$route(make_req("GET", "/car/ratio/."), PlumberResponse$new()), list(error = "404 - Resource Not Found")) expect_equal(r$route(make_req("GET", "/car/sold/true"), PlumberResponse$new()), TRUE) }) plumber/tests/testthat/test-globals.R0000644000176200001440000000327013304040260017437 0ustar liggesuserscontext("global settings") test_that("parseOneGlobal parses with various formats", { fields <- list(info=list()) # No leading space g <- parseOneGlobal(fields, "#'@apiTitle Title") expect_equal(g$info$title, "Title") # Plumber-style g <- parseOneGlobal(fields, "#* @apiTitle Title") expect_equal(g$info$title, "Title") #Extra space g <- parseOneGlobal(fields, "#* @apiTitle Title ") expect_equal(g$info$title, "Title") }) test_that("parseGlobals works", { # Test all fields lines <- c("#' @apiTitle title", "#' @apiDescription description", "#' @apiTOS tos", "#' @apiContact contact", "#' @apiLicense license", "#' @apiVersion version", "#' @apiHost host", "#' @apiBasePath basepath", "#' @apiSchemes schemes", "#' @apiConsumes consumes", "#' @apiProduces produces", "#' @apiTag tag description", "#' @apiTag tag2 description2") fields <- parseGlobals(lines) expect_equal(fields, list( info=list( title="title", description="description", termsOfService="tos", contact="contact", license="license", version="version" ), host="host", basePath="basepath", schemes="schemes", consumes="consumes", produces="produces", tags=data.frame(name=c("tag","tag2"),description=c("description","description2"), stringsAsFactors = FALSE) )) }) test_that("Globals can't contain duplicate tags", { lines <- c("#* @apiTag test description1", "#* @apiTag test description2") expect_error(parseGlobals(lines), "Duplicate tag definition specified.") }) plumber/tests/testthat/test-static.R0000644000176200001440000000515313304040260017305 0ustar liggesuserscontext("Static") pr <- PlumberStatic$new("files/static") test_that("the response is reurned", { res <- PlumberResponse$new() val <- pr$route(make_req("GET", "/test.txt"), res) expect_true(inherits(val, "PlumberResponse")) }) test_that("static txt file is served", { res <- PlumberResponse$new() pr$route(make_req("GET", "/test.txt"), res) expect_equal(res$headers$`Content-type`, "text/plain") expect_equal(rawToChar(res$body), "I am a text file.\n") }) test_that("static html file is served", { res <- PlumberResponse$new() pr$route(make_req("GET", "/index.html"), res) expect_equal(res$headers$`Content-type`, "text/html; charset=UTF-8") expect_equal(rawToChar(res$body), "I am HTML\n") }) test_that("root requests are routed to index.html", { res <- PlumberResponse$new() pr$route(make_req("GET", "/"), res) expect_equal(res$headers$`Content-type`, "text/html; charset=UTF-8") expect_equal(rawToChar(res$body), "I am HTML\n") }) test_that("static binary file is served", { res <- PlumberResponse$new() pr$route(make_req("GET", "/test.txt.zip"), res) expect_equal(res$headers$`Content-type`, "application/octet-stream") bod <- res$body zipf <- file("files/static/test.txt.zip", "rb") bin <- readBin(zipf, "raw", n=1000) close(zipf) expect_equal(bin, bod) }) test_that("404s are handled", { res <- PlumberResponse$new() pr$route(make_req("GET", "/i-dont-exist"), res) expect_equal(res$status, 404) }) test_that("PUTs error", { res <- PlumberResponse$new() pr$route(make_req("PUT", "/"), res) expect_equal(res$status, 400) }) test_that("files are parsed properly", { p <- plumber$new("files/static.R") expect_length(p$mounts, 2) res <- PlumberResponse$new() req <- make_req("GET", "/static/test.txt") p$route(req=req, res=res) expect_equal(length(res$body), 18) expect_equal(res$status, 200) expect_equal(res$headers$`Content-type`, "text/plain") res <- PlumberResponse$new() req <- make_req("GET", "/public/test.txt") p$route(req=req, res=res) expect_equal(length(res$body), 18) expect_equal(res$status, 200) expect_equal(res$headers$`Content-type`, "text/plain") }) test_that("no directory throws error", { expect_error(plumber$new("files/static-nodir.R"), "No directory specified") }) test_that("expressions work as options", { pr <- plumber$new() stat <- PlumberStatic$new("files/static", {list()}) pr$mount("/public", stat) res <- PlumberResponse$new() pr$route(make_req("GET", "/public/test.txt"), res) expect_equal(res$headers$`Content-type`, "text/plain") expect_equal(rawToChar(res$body), "I am a text file.\n") }) plumber/tests/testthat/test-querystring.R0000644000176200001440000000160713304040260020412 0ustar liggesuserscontext("query strings") test_that("query strings are properly parsed", { expect_equal(parseQS("?a=1"), list(a="1")) expect_equal(parseQS("b=2"), list(b="2")) expect_equal(parseQS("a=1&b=2&c=url%20encoded"), list(a="1", b="2", c="url encoded")) }) test_that("special characters in query strings are handled properly", { expect_equal(parseQS("?a=1+.#"), list(a="1+.#")) expect_equal(parseQS("?a=a%20b"), list(a="a b")) }) test_that("null an empty strings return empty list", { expect_equal(parseQS(NULL), list()) expect_equal(parseQS(""), list()) }) test_that("incomplete query strings are ignored", { expect_equivalent(parseQS("a="), list()) # It's technically a named list() expect_equal(parseQS("a=1&b=&c&d=1"), list(a="1", d="1")) }) test_that("query strings with duplicates are made into vectors", { expect_equal(parseQS("a=1&a=2&a=3&a=4"), list(a=c("1", "2", "3", "4"))) })plumber/tests/testthat/test-swagger.R0000644000176200001440000000717213304040260017460 0ustar liggesuserscontext("swagger") test_that("plumberToSwaggerType works", { expect_equal(plumberToSwaggerType("bool"), "boolean") expect_equal(plumberToSwaggerType("logical"), "boolean") expect_equal(plumberToSwaggerType("double"), "number") expect_equal(plumberToSwaggerType("numeric"), "number") expect_equal(plumberToSwaggerType("int"), "integer") expect_equal(plumberToSwaggerType("character"), "string") expect_error(plumberToSwaggerType("flargdarg"), "Unrecognized type:") }) test_that("response attributes are parsed", { lines <- c( "#' @get /", "#' @response 201 This is response 201", "#' @response 202 Here's second", "#' @response 203 Here's third", "#' @response default And default") b <- parseBlock(length(lines), lines) expect_length(b$responses, 4) expect_equal(b$responses$`201`, list(description="This is response 201")) expect_equal(b$responses$`202`, list(description="Here's second")) expect_equal(b$responses$`203`, list(description="Here's third")) expect_equal(b$responses$default, list(description="And default")) b <- parseBlock(1, "") expect_null(b$responses) }) test_that("params are parsed", { lines <- c( "#' @get /", "#' @param test Test docs", "#' @param required:character* Required param", "#' @param another:int Another docs") b <- parseBlock(length(lines), lines) expect_length(b$params, 3) expect_equal(b$params$another, list(desc="Another docs", type="integer", required=FALSE)) expect_equal(b$params$test, list(desc="Test docs", type=NA, required=FALSE)) expect_equal(b$params$required, list(desc="Required param", type="string", required=TRUE)) b <- parseBlock(1, "") expect_null(b$params) }) # TODO #test_that("prepareSwaggerEndpoints works", { #}) test_that("extractResponses works", { # Empty r <- extractResponses(NULL) expect_equal(r, defaultResp) # Response constructor actually defaults to NA, so that's an important case, too r <- extractResponses(NA) expect_equal(r, defaultResp) # Responses with no default customResps <- list("200" = list()) r <- extractResponses(customResps) expect_length(r, 2) expect_equal(r$default, defaultResp$default) expect_equal(r$`200`, customResps$`200`) }) test_that("extractSwaggerParams works", { ep <- list(id=list(desc="Description", type="integer", required=FALSE), id2=list(desc="Description2", required=FALSE), # No redundant type specification make=list(desc="Make description", type="string", required=FALSE)) pp <- data.frame(name=c("id", "id2"), type=c("int", "int")) params <- extractSwaggerParams(ep, pp) expect_equal(as.list(params[1,]), list(name="id", description="Description", `in`="path", required=TRUE, # Made required b/c path arg type="integer")) expect_equal(as.list(params[2,]), list(name="id2", description="Description2", `in`="path", required=TRUE, # Made required b/c path arg type="integer")) expect_equal(as.list(params[3,]), list(name="make", description="Make description", `in`="query", required=FALSE, type="string")) # If id were not a path param it should not be promoted to required params <- extractSwaggerParams(ep, NULL) expect_equal(params$required[params$name=="id"], FALSE) expect_equal(params$type[params$name=="id"], "integer") params <- extractSwaggerParams(NULL, NULL) expect_equal(nrow(params), 0) expect_equal(ncol(params), 5) }) plumber/tests/testthat/files/0000755000176200001440000000000013305322734016026 5ustar liggesusersplumber/tests/testthat/files/endpoints-empty.R0000644000176200001440000000003013304040260021267 0ustar liggesusers#* @get function() { } plumber/tests/testthat/files/filterpath.R0000644000176200001440000000005113304040260020275 0ustar liggesusers#* @filter test #* @get / function(){ } plumber/tests/testthat/files/filter-empty.R0000644000176200001440000000003213304040260020553 0ustar liggesusers#* @filter function(){ } plumber/tests/testthat/files/path-params.R0000644000176200001440000000064713304040260020363 0ustar liggesusers#* @get /car/ function(id){ id } #* @get /car/int/ function(id){ id } #* @get /car//sell/ function(id, price){ list(id=id, price=price) } #* @get /car/ratio/ function(ratio){ ratio } #* @get /car/sold/ function(sold){ sold } #* @post /car/ function(req){ req$args$id } #* @get /car//buy/ function(id, price){ list(id=id, price=price) } plumber/tests/testthat/files/serializer-nonexistent.R0000644000176200001440000000006213304040260022662 0ustar liggesusers#* @serializer flargdarg #* @get / function(){ } plumber/tests/testthat/files/static-nodir.R0000644000176200001440000000002213304040260020531 0ustar liggesusers#* @assets list() plumber/tests/testthat/files/filters.R0000644000176200001440000000021413304040260017604 0ustar liggesusers#* @filter something function(req){ req$args$hello <- 23 } #*@filter nospace function(){ } #* @get / function(req){ req$args$hello } plumber/tests/testthat/files/preempt-redundant.R0000644000176200001440000000007613304040260021600 0ustar liggesusers #* @preempt inc #* @preempt inc #* @post here function(){ } plumber/tests/testthat/files/preempt.R0000644000176200001440000000044313304040260017614 0ustar liggesusers#* @filter testFun function(){ } #* @filter testFun2 function(){ } #* @filter testFun3 function(){ } #* @preempt testFun #* @get / function(){ } #* @preempt test #* Excluded function(){ } #* @preempt testFun2 #* @get / #* function(){ } #*@preempt testFun3 #*@post / function(){ } plumber/tests/testthat/files/endpoints-old.R0000644000176200001440000000072013304040260020715 0ustar liggesusers#' @stuff #' @more- stuff #' #' comments function(req, res, forward){ 4 } #' @get /test #' @post /test #' @more stuff #' hey foo <- function(a, b, ..., req, res, forward){ 5 } #' Not an API #' @param things foo <- function(req, res, forward){ 6 } #' @post / #' one line function(req, res, forward){x <- 9; x + 1} #' Spaces in between #' @delete / function(req, res, forward){ x <- 10 x + 2 } #'@get nowhitespace function(req, res, forward){ 14 } plumber/tests/testthat/files/readme.R0000644000176200001440000000024513304040260017375 0ustar liggesusers#* @get /mean normalMean <- function(samples=10){ data <- rnorm(samples) mean(data) } #* @post /sum addTwo <- function(a, b){ as.numeric(a) + as.numeric(b) } plumber/tests/testthat/files/static.R0000644000176200001440000000023113304040260017422 0ustar liggesusers#* @assets ./files/static static list() #* @assets files/static /static list() #*@assets ./files/static list() #* @assets files/static function(){ } plumber/tests/testthat/files/terminal-filter.R0000644000176200001440000000024413304040260021235 0ustar liggesusers #* @filter terminal function(){ # We don't call forward(), implying that we've terminated the request within # this filter. 1 } #* @get / function(){ 2 } plumber/tests/testthat/files/endpoints.R0000644000176200001440000000075513304040260020151 0ustar liggesusers#* @stuff #* @more- stuff #* #* comments function(req, res, forward){ 4 } #* @get /test #* @post /test #* @more stuff #' @param req Roxygen params #* hey foo <- function(a, b, ..., req, res, forward){ 5 } #* Not an API #* @param things foo <- function(req, res, forward){ 6 } #* @post / #* one line function(req, res, forward){x <- 9; x + 1} #* Spaces in between #* @delete / function(req, res, forward){ x <- 10 x + 2 } #*@get nowhitespace function(req, res, forward){ 14 } plumber/tests/testthat/files/serializer.R0000644000176200001440000000150413304040260020310 0ustar liggesusers#* @serializer custom #* @get / function(){ 1 } #* @filter foo #* @serializer custom2 function(req, res){ if (req$PATH_INFO != '/filter-catch'){ forward() } } #* @filter foo2 function(req, res, type=""){ if (type == "json"){ res$serializer <- plumber:::serializer_json() } forward() } #* @get /something function(){ 4 } #* @get /another function(req, res){ res$serializer <- function(val, req, res, errorHandler){ list(status=201L, headers=list(), body="CUSTOM3") } 5 } #* @get /short-json #* @json function(){ "JSON" } #* @get /short-html #* @html function(){ "HTML" } #* @get /single-arg-ser #* @serializer customOneArg list(single="hi there") function(){ "COA" } #* @get /multi-arg-ser #* @serializer customMultiArg list(first=LETTERS[1], second=4+4, third=4.3) function(){ "MAS" } plumber/tests/testthat/files/serializer-redundant.R0000644000176200001440000000010413304040260022265 0ustar liggesusers #* @serializer inc #* @serializer inc #* @post here function(){ } plumber/tests/testthat/files/html.R0000644000176200001440000000010713304040260017101 0ustar liggesusers#* @serializer html #* @get / function(){ "Test here" } plumber/tests/testthat/files/image.R0000644000176200001440000000041213304040260017216 0ustar liggesusers#* @png #* @get /png function() { plot(1:10) } #* @jpeg #* @get /jpeg function() { plot(1:10) } #' @png (width = 150, height=150) #' @get /littlepng function(){ plot(1:10) } #' @jpeg (width = 150, height=150) #' @get /littlejpeg function(){ plot(1:10) } plumber/tests/testthat/files/warn.R0000644000176200001440000000015113304040260017103 0ustar liggesusers #* @get /warning function(res){ warning("this is a warning") res$status <- (options("warn")[[1]]) } plumber/tests/testthat/files/preempt-empty.R0000644000176200001440000000004513304040260020746 0ustar liggesusers#* @preempt #* @get / function(){ } plumber/tests/testthat/files/plumber.R0000644000176200001440000000073413304040260017611 0ustar liggesusers#* @stuff #* @more- stuff #* #* comments function(req, res, forward){ 4 } #* @get /test #* @post /test #* @more stuff #* hey foo <- function(a, b, ..., req, res, forward){ 5 } #* Not an API #* @param things foo <- function(req, res, forward){ 6 } #* @post / #* one line function(req, res, forward){x <- 9; x + 1} #* Spaces in between #* @delete / function(req, res, forward){ x <- 10 x + 2 } #*@get nowhitespace function(req, res, forward){ 14 } plumber/tests/testthat/files/entrypoint/0000755000176200001440000000000013305412327020237 5ustar liggesusersplumber/tests/testthat/files/entrypoint/entrypoint.R0000644000176200001440000000055313304040260022570 0ustar liggesusersplumber::addSerializer("fake", function(){ function(val, req, res, errorHandler){ tryCatch({ json <- jsonlite::toJSON(val) res$setHeader("Content-Type", "application/json") res$body <- paste0("FAKE", json) return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } }) plumber$new("./plumber.R") plumber/tests/testthat/files/entrypoint/plumber.R0000644000176200001440000000006113304040260022015 0ustar liggesusers#* @get / #* @serializer fake function(){ 13 } plumber/tests/testthat/files/router.R0000644000176200001440000000105113304040260017454 0ustar liggesusers #* @get / #* @preempt __first__ function(){ "first" } #* @get /abc function(){ "abc get" } #* @post /abc function(){ "abc post" } #* @filter filt1 function(req, res){ forward() } #* @filter filt2 function(req, res){ forward() } #* @use /dog #* @preempt filt2 function(){ "dog use" } #* @get /dog #* @preempt filt1 function(){ "dog get" } #* @get /error function(){ stop("ERROR") } #* @get /response function(res){ res$body <- "overridden" res$status <- 123 res } #* @get /path1 #* @get /path2 function(){ "dual path" } plumber/tests/testthat/files/preempt-nonexistent.R0000644000176200001440000000005713304040260022171 0ustar liggesusers#* @preempt flargdarg #* @get / function(){ } plumber/tests/testthat/files/integration.R0000644000176200001440000000226313304040260020465 0ustar liggesusers library(stringi) #* @preempt auth #* @use / function(a=1){ list(msg=paste0("Welcome to the root URL! a = ", a)) } #* @filter auth function(req, res){ if (!stri_startswith_fixed(req$QUERY_STRING, "?user=")){ # Don't continue res$status <- 401 return(list(err="Not authorized")) } user <- substr(req$QUERY_STRING, 7, nchar(req$QUERY_STRING)) req$username <- user forward() } #* @get /me function(req, res){ list(name=req$username) } #* @get /error #* @preempt auth function(req, res){ stop("I throw an error!") } #* @get /set #* @preempt auth function(req){ req$testVal <- 1 } #* @get /get #* @preempt auth function(req){ req$testVal } #* This is an HTML file that will demonstrate the HTTPUV bug in which req's that #* share a TCP channel also share an environment. This is why we force connections #* to close for now. #* @get /test #* @preempt auth #* @html function(){ ' ' } plumber/tests/testthat/files/verbs.R0000644000176200001440000000050413304040260017257 0ustar liggesusers#* @use /some function(){ } #* @get /get function() { } #* @put /put function(req, res, forward){ 7 } #* @post /post function() { } #* @delete /delete function() { } #* @get /test #* @post /test function(){ } #* @head /head function() { } #* @options /options function(){ } #* @patch /patch function(){ } plumber/tests/testthat/files/serializer-empty.R0000644000176200001440000000005013304040260021437 0ustar liggesusers#* @serializer #* @get / function(){ } plumber/tests/testthat/files/entrypoint-bad/0000755000176200001440000000000013304040260020753 5ustar liggesusersplumber/tests/testthat/files/entrypoint-bad/entrypoint.R0000644000176200001440000000003413304040260023306 0ustar liggesusers"I DON'T KNOW WHAT TO DO!!" plumber/tests/testthat/files/entrypoint-bad/plumber.R0000644000176200001440000000006113304040260022541 0ustar liggesusers#* @get / #* @serializer fake function(){ 13 } plumber/tests/testthat/files/filter-inject.R0000644000176200001440000000013513304040260020675 0ustar liggesusers#* @filter foo function(req){ req$args$hello <- 13 } #* @get / function(hello){ hello } plumber/tests/testthat/files/content-type.R0000644000176200001440000000012613304040260020567 0ustar liggesusers#* @serializer contentType list(type="text/plain") #* @get / function(){ "RESULT" } plumber/tests/testthat/files/filterasset.R0000644000176200001440000000007113304040260020462 0ustar liggesusers#* @filter test #* @assets ./files/static function(){ } plumber/tests/testthat/files/in-env.R0000644000176200001440000000024713304040260017336 0ustar liggesusersa <- 13 15 #* Some docs #* @get / function(req, res, forward){ x <- 2 x + a } #* Moar docs #* @post / useless <- function(req, res, forward){ y <- 3 y + a } plumber/tests/testthat/files/filter-redundant.R0000644000176200001440000000005113304040260021402 0ustar liggesusers#* @filter a #* @filter b function(){ } plumber/tests/testthat/files/static/0000755000176200001440000000000013305412327017313 5ustar liggesusersplumber/tests/testthat/files/static/index.html0000644000176200001440000000002713304040260021277 0ustar liggesusersI am HTML plumber/tests/testthat/files/static/test.txt.zip0000644000176200001440000000026213304040260021624 0ustar liggesusersPKLJGtest.txtUX #$V#VTHUHT(I(QHIPKoGoPKLJGoGo @test.txtUX#$V#VPKBZplumber/tests/testthat/files/static/test.txt0000644000176200001440000000002213304040260021015 0ustar liggesusersI am a text file. plumber/tests/testthat/files/include/0000755000176200001440000000000013305335716017455 5ustar liggesusersplumber/tests/testthat/files/include/test.md0000644000176200001440000000162213304040260020741 0ustar liggesusersOverview -------- This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see . R Output -------- When you click the **Knit** button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this: summary(cars) ## speed dist ## Min. : 4.0 Min. : 2.00 ## 1st Qu.:12.0 1st Qu.: 26.00 ## Median :15.0 Median : 36.00 ## Mean :15.4 Mean : 42.98 ## 3rd Qu.:19.0 3rd Qu.: 56.00 ## Max. :25.0 Max. :120.00 Plots ----- You can also embed plots, for example: Note that the `echo = FALSE` parameter was added to the code chunk to prevent printing of the R code that generated the plot. plumber/tests/testthat/files/include/test-html.html0000644000176200001440000000337213305301735022263 0ustar liggesusers test

Overview

This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see http://rmarkdown.rstudio.com.

R Output

When you click the Knit button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this:

summary(cars)
##      speed           dist
##  Min.   : 4.0   Min.   :  2.00
##  1st Qu.:12.0   1st Qu.: 26.00
##  Median :15.0   Median : 36.00
##  Mean   :15.4   Mean   : 42.98
##  3rd Qu.:19.0   3rd Qu.: 56.00
##  Max.   :25.0   Max.   :120.00

Plots

You can also embed plots, for example:

Note that the echo = FALSE parameter was added to the code chunk to prevent printing of the R code that generated the plot.

plumber/tests/testthat/files/include/test.Rmd0000644000176200001440000000154113304040260021063 0ustar liggesusers--- title: "test" author: "Jeff Allen" date: "June 14, 2015" output: html_document --- ```{r setup, include=FALSE} knitr::opts_chunk$set(eval = TRUE, include = TRUE, echo = TRUE) ``` ## Overview This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see . ## R Output When you click the **Knit** button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this: ```{r cars} summary(cars) ``` ## Plots You can also embed plots, for example: ```{r pressure, echo=FALSE} plot(pressure) ``` Note that the `echo = FALSE` parameter was added to the code chunk to prevent printing of the R code that generated the plot. plumber/tests/testthat/files/include/test.txt0000644000176200001440000000002113304040260021150 0ustar liggesuserstest.txt content plumber/tests/testthat/files/includes.R0000644000176200001440000000045613305301735017762 0ustar liggesusers#* @get / function(req, res){ include_file("include/test.txt", res) } #* @get /html function(req, res){ include_html("include/test-html.html", res) } #* @get /rmd function(req, res){ include_rmd("include/test.Rmd", res) } #* @get /md function(req, res){ include_md("include/test.md", res) } plumber/tests/testthat/test-serializer-htmlwidgets.R0000644000176200001440000000230513305274406022530 0ustar liggesuserscontext("htmlwidgets serializer") # Render a simple HTML widget using the visNetwork package renderWidget <- function(){ nodes <- data.frame(id = 1:6, title = paste("node", 1:6), shape = c("dot", "square"), size = 10:15, color = c("blue", "red")) edges <- data.frame(from = 1:5, to = c(5, 4, 6, 3, 3)) visNetwork::visNetwork(nodes, edges) %>% visNetwork::visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE) } test_that("htmlwidgets serialize properly", { # Solaris doesn't have htmlwidgets available for some reason. skip_on_cran() w <- renderWidget() val <- serializer_htmlwidget()(w, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$headers$`Content-Type`, "text/html; charset=utf-8") # Check that content is encoded expect_match(val$body, "url(data:image/png;base64", fixed = TRUE) }) test_that("Errors call error handler", { errors <- 0 errHandler <- function(req, res, err){ errors <<- errors + 1 } expect_equal(errors, 0) suppressWarnings( serializer_htmlwidget()(parse(text="hi"), list(), PlumberResponse$new("htmlwidget"), err = errHandler) ) expect_equal(errors, 1) }) plumber/tests/testthat/test-include.R0000644000176200001440000000216613305334207017452 0ustar liggesuserscontext("Includes") test_that("Includes work", { r <- plumber$new("files/includes.R") # When running, we setwd to the file's dir. Simulate that here. cwd <- getwd() on.exit( { setwd(cwd) } ) setwd("files") res <- PlumberResponse$new() val <- r$route(make_req("GET", "/"), res) expect_equal(val$body, "test.txt content") expect_equal(val$headers$`Content-type`, NULL) res <- PlumberResponse$new() val <- r$route(make_req("GET", "/html"), res) expect_match(val$body, ".*\\s*$") expect_equal(val$headers$`Content-type`, "text/html; charset=utf-8") # Skip these tests on some CRAN instances if (rmarkdown::pandoc_available()){ res <- PlumberResponse$new() val <- r$route(make_req("GET", "/md"), res) expect_match(val$body, "R Output.*\\s*$") expect_equal(val$headers$`Content-type`, "text/html; charset=utf-8") res <- PlumberResponse$new() val <- r$route(make_req("GET", "/rmd"), res) expect_match(val$body, "\\s*$") expect_equal(val$headers$`Content-type`, "text/html; charset=utf-8") } }) plumber/tests/testthat/test-cookies.R0000644000176200001440000000451613304040260017454 0ustar liggesuserscontext("Cookies") test_that("cookies are parsed", { co <- parseCookies("spaced=cookie%20here; another=2") expect_equal(co$spaced, "cookie here") expect_equal(co$another, "2") }) test_that("missing cookies are an empty list", { co <- parseCookies("") expect_equal(co, list()) }) test_that("the cookies list is set", { req <- new.env() req$HTTP_COOKIE <- "abc=123" cookieFilter(req) expect_equal(req$cookies$abc, "123") }) test_that("missing cookie values are empty string", { req <- new.env() req$HTTP_COOKIE <- "abc=" cookieFilter(req) expect_equal(req$cookies$abc, "") }) test_that("cookies can convert to string", { testthat::skip_on_cran() expect_equal(cookieToStr("abc", 123), "abc=123") expect_equal(cookieToStr("complex", "string with spaces"), "complex=string%20with%20spaces") expect_equal(cookieToStr("abc", 123, path="/somepath"), "abc=123; Path=/somepath") expect_equal(cookieToStr("abc", 123, http=TRUE, secure=TRUE), "abc=123; HttpOnly; Secure") # Test date in the future expiresSec <- 10 expires <- Sys.time() + expiresSec expyStr <- format(expires, format="%a, %e %b %Y %T", tz="GMT", usetz=TRUE) # TODO: this test is vulnerable to Sys.time() crossing over a second boundary in between the # line above and below. # When given as a number of seconds expect_equal(cookieToStr("abc", 123, expiration=expiresSec), paste0("abc=123; Expires= ", expyStr, "; Max-Age= ", expiresSec)) # When given as a POSIXct # difftime is exclusive, so the Max-Age may be off by one on positive time diffs. expect_equal(cookieToStr("abc", 123, expiration=expires), paste0("abc=123; Expires= ", expyStr, "; Max-Age= ", expiresSec-1)) # Works with a negative number of seconds expiresSec <- -10 expires <- Sys.time() + expiresSec expyStr <- format(expires, format="%a, %e %b %Y %T", tz="GMT", usetz=TRUE) # TODO: this test is vulnerable to Sys.time() crossing over a second boundary in between the # line above and below. # When given as a number of seconds expect_equal(cookieToStr("abc", 123, expiration=expiresSec), paste0("abc=123; Expires= ", expyStr, "; Max-Age= ", expiresSec)) # When given as a POSIXct expect_equal(cookieToStr("abc", 123, expiration=expires), paste0("abc=123; Expires= ", expyStr, "; Max-Age= ", expiresSec)) }) plumber/tests/testthat/test-default-handlers.R0000644000176200001440000000244213304040260021236 0ustar liggesuserscontext("default handlers") test_that("404 handler sets 404", { res <- PlumberResponse$new() val <- default404Handler(list(), res) expect_equal(res$status, 404) expect_match(val$error, "404") expect_match(val$error, "Not Found") }) test_that("default error handler returns an object with an error property", { res <- PlumberResponse$new() options('plumber.debug' = FALSE) capture.output(val <- defaultErrorHandler()(list(), res, "I'm an error!")) expect_match(val$error, "500") expect_match(val$error, "Internal server error") expect_equal(res$status, 500) }) test_that("error handler doesn't clobber non-200 status", { res <- PlumberResponse$new() options('plumber.debug' = FALSE) res$status <- 403 capture.output(val <- defaultErrorHandler()(list(), res, "I'm an error!")) expect_match(val$error, "Internal error") expect_equal(res$status, 403) }) test_that("error handler only includes message in debug mode.", { res <- PlumberResponse$new() options('plumber.debug' = FALSE) capture.output(val <- defaultErrorHandler()(list(), res, "I'm an error!")) expect_null(val$message) res <- PlumberResponse$new() options('plumber.debug' = TRUE) capture.output(val <- defaultErrorHandler()(list(), res, "I'm an error!")) expect_equal(val$message, "I'm an error!") }) plumber/tests/testthat/test-serializer-json.R0000644000176200001440000000232513304040260021134 0ustar liggesuserscontext("JSON serializer") test_that("JSON serializes properly", { l <- list(a=1, b=2, c="hi") val <- serializer_json()(l, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$headers$`Content-Type`, "application/json") expect_equal(val$body, jsonlite::toJSON(l)) }) test_that("Errors call error handler", { errors <- 0 errHandler <- function(req, res, err){ errors <<- errors + 1 } expect_equal(errors, 0) serializer_json()(parse(text="hi"), list(), PlumberResponse$new("json"), err = errHandler) expect_equal(errors, 1) }) context("Unboxed JSON serializer") test_that("Unboxed JSON serializes properly", { l <- list(a=1, b=2, c="hi") val <- serializer_unboxed_json()(l, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$headers$`Content-Type`, "application/json") expect_equal(val$body, jsonlite::toJSON(l, auto_unbox = TRUE)) }) test_that("Unboxed JSON errors call error handler", { errors <- 0 errHandler <- function(req, res, err){ errors <<- errors + 1 } expect_equal(errors, 0) serializer_unboxed_json()(parse(text="hi"), list(), PlumberResponse$new("json"), err = errHandler) expect_equal(errors, 1) }) plumber/tests/testthat/test-preempt.R0000644000176200001440000000121713304040260017467 0ustar liggesuserscontext("Preempts") test_that("preempts work", { r <- plumber$new("files/preempt.R") expect_equal(length(r$endpoints), 3) expect_length(r$endpoints[["testFun"]], 1) expect_length(r$endpoints[["testFun2"]], 1) expect_length(r$endpoints[["testFun3"]], 1) }) test_that("Redundant preempts fail", { expect_error(plumber$new("files/preempt-redundant.R"), regexp="Multiple @preempts") }) test_that("Empty preempts fail", { expect_error(plumber$new("files/preempt-empty.R"), regexp="No @preempt specified") }) test_that("Non-existant preempts fail", { expect_error(plumber$new("files/preempt-nonexistent.R"), regexp="The given @preempt") }) plumber/tests/testthat/test-serializer.R0000644000176200001440000000764413304040260020176 0ustar liggesuserscontext("Serializer") test_that("Responses returned directly aren't serialized", { res <- PlumberResponse$new("") r <- plumber$new("files/router.R") val <- r$serve(make_req("GET", "/response"), res) expect_equal(val$body, "overridden") expect_equal(val$status, 123) }) test_that("JSON is the default serializer", { res <- PlumberResponse$new() r <- plumber$new("files/router.R") expect_equal(r$serve(make_req("GET", "/"), res)$headers$`Content-Type`, "application/json") }) test_that("Overridden serializers apply on filters and endpoints", { customSer <- function(){ function(val, req, res, errorHandler){ list(status=201L, headers=list(), body="CUSTOM") } } addSerializer("custom", customSer) custom2Ser <- function(){ function(val, req, res, errorHandler){ list(status=201L, headers=list(), body="CUSTOM2") } } addSerializer("custom2", custom2Ser) addSerializer("customOneArg", function(single){ function(val, req, res, errorHandler){ list(status=200L, headers=list(), body=list(val=val, arg=single)) } }) addSerializer("customMultiArg", function(first, second, third){ function(val, req, res, errorHandler){ list(status=200L, headers=list(), body=list(val=val, args=list(first=first, second=second, third=third))) } }) r <- plumber$new("files/serializer.R") res <- PlumberResponse$new("json") expect_equal(r$serve(make_req("GET", "/"), res)$body, "CUSTOM") expect_equal(res$serializer, customSer()) res <- PlumberResponse$new("json") expect_equal(r$serve(make_req("GET", "/filter-catch"), res)$body, "CUSTOM2") expect_equal(res$serializer, custom2Ser()) req <- make_req("GET", "/something") res <- PlumberResponse$new(customSer()) expect_equal(r$serve(req, res)$body, "CUSTOM") res$serializer <- customSer() req <- make_req("GET", "/something") req$QUERY_STRING <- "type=json" expect_equal(r$serve(req, res)$body, jsonlite::toJSON(4)) res$serializer <- serializer_json() res <- PlumberResponse$new("json") expect_equal(r$serve(make_req("GET", "/another"), res)$body, "CUSTOM3") res <- PlumberResponse$new() expect_equal(r$serve(make_req("GET", "/short-json"), res)$body, jsonlite::toJSON("JSON")) expect_equal_functions(res$serializer, serializer_json()) res <- PlumberResponse$new() expect_equal(r$serve(make_req("GET", "/short-html"), res)$body, "HTML") expect_equal_functions(res$serializer, serializer_html()) res <- PlumberResponse$new() body <- r$serve(make_req("GET", "/single-arg-ser"), res)$body expect_equal(body$val, "COA") expect_equal(body$arg, "hi there") res <- PlumberResponse$new() body <- r$serve(make_req("GET", "/multi-arg-ser"), res)$body expect_equal(body$val, "MAS") expect_equal(body$args$first, "A") expect_equal(body$args$second, 8) expect_equal(body$args$third, 4.3) }) test_that("Overridding the attached serializer in code works.", { }) test_that("Redundant serializers fail", { addSerializer("inc", function(val, req, res, errorHandler){ list(status=201L, headers=list(), body="CUSTOM2") }) expect_error(plumber$new("files/serializer-redundant.R"), regexp="Multiple @serializers") }) test_that("Empty serializers fail", { expect_error(plumber$new("files/serializer-empty.R"), regexp="No @serializer specified") }) test_that("Non-existant serializers fail", { expect_error(plumber$new("files/serializer-nonexistent.R"), regexp="No such @serializer") }) test_that("nullSerializer serializes properly", { v <- "

Hi!

" val <- nullSerializer()(v, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$body, v) }) test_that("nullSerializer errors call error handler", { errors <- 0 errHandler <- function(req, res, err){ errors <<- errors + 1 } expect_equal(errors, 0) nullSerializer()(parse(stop("I crash")), list(), PlumberResponse$new("json"), err = errHandler) expect_equal(errors, 1) }) plumber/tests/testthat/test-shared-secret.R0000644000176200001440000000105613304040260020545 0ustar liggesuserscontext("shared secret") test_that("requests with shared secrets pass, w/o fail", { options(`plumber.sharedSecret`="abcdefg") pr <- plumber$new() pr$handle("GET", "/", function(){ 123 }) # No shared secret req <- make_req("GET", "/") res <- PlumberResponse$new() capture.output(pr$route(req, res)) expect_equal(res$status, 400) # Set shared secret assign("HTTP_PLUMBER_SHARED_SECRET", "abcdefg", envir=req) res <- PlumberResponse$new() pr$route(req, res) expect_equal(res$status, 200) options(`plumber.sharedSecret`=NULL) }) plumber/tests/testthat/test-serializer-html.R0000644000176200001440000000111313304040260021121 0ustar liggesuserscontext("HTML serializer") test_that("HTML serializes properly", { v <- "

Hi!

" val <- serializer_html()(v, list(), PlumberResponse$new(), stop) expect_equal(val$status, 200L) expect_equal(val$headers$`Content-Type`, "text/html; charset=utf-8") expect_equal(val$body, v) }) test_that("Errors call error handler", { errors <- 0 errHandler <- function(req, res, err){ errors <<- errors + 1 } expect_equal(errors, 0) serializer_html()(parse(stop("I crash")), list(), PlumberResponse$new("json"), err = errHandler) expect_equal(errors, 1) }) plumber/tests/testthat/test-parse-block.R0000644000176200001440000000452113304040260020216 0ustar liggesuserscontext("block parsing") test_that("trimws works", { expect_equal(trimws(" hi there \t "), "hi there") expect_equal(trimws("hi there\t"), "hi there") expect_equal(trimws("hi "), "hi") }) test_that("parseBlock works", { lines <- c( "#' @get /", "#' @post /", "#' @filter test", "#' @serializer json") b <- parseBlock(length(lines), lines) expect_length(b$path, 2) expect_equal(b$path[[1]], list(verb="POST", path="/")) expect_equal(b$path[[2]], list(verb="GET", path="/")) expect_equal(b$filter, "test") expect_equal_functions(b$serializer, serializer_json()) }) test_that("parseBlock images", { lines <- c("#'@png") b <- parseBlock(length(lines), lines) expect_equal(b$image, "png") expect_equal(b$imageAttr, "") lines <- c("#'@jpeg") b <- parseBlock(length(lines), lines) expect_equal(b$image, "jpeg") expect_equal(b$imageAttr, "") # Whitespace is fine lines <- c("#' @jpeg \t ") b <- parseBlock(length(lines), lines) expect_equal(b$image, "jpeg") expect_equal(b$imageAttr, "") # No whitespace is fine lines <- c("#' @jpeg(w=1)") b <- parseBlock(length(lines), lines) expect_equal(b$image, "jpeg") expect_equal(b$imageAttr, "(w=1)") # Additional chars after name don't count as image tags lines <- c("#' @jpegs") b <- parseBlock(length(lines), lines) expect_null(b$image) expect_null(b$imageAttr) # Properly formatted arguments work lines <- c("#'@jpeg (width=100)") b <- parseBlock(length(lines), lines) expect_equal(b$image, "jpeg") expect_equal(b$imageAttr, "(width=100)") # Ill-formatted arguments return a meaningful error lines <- c("#'@jpeg width=100") expect_error(parseBlock(length(lines), lines), "Supplemental arguments to the image serializer") }) test_that("Block can't be multiple mutually exclusive things", { srcref <- c(3,4) addE <- function(){ fail() } addF <- function(){ fail() } addA <- function(){ fail() } expect_error({ activateBlock(srcref, c("#' @get /", "#' @assets /", "function(){}"), function(){}, addE, addF, addA) }, "A single function can only be") }) test_that("Block can't contain duplicate tags", { lines <- c("#* @tag test", "#* @tag test") expect_error(parseBlock(length(lines), lines), "Duplicate tag specified.") }) # TODO: more testing around filter, assets, endpoint, etc. plumber/tests/testthat/helper-mock-request.R0000644000176200001440000000033713304040260020734 0ustar liggesusers make_req <- function(verb, path, qs="", body=""){ req <- new.env() req$REQUEST_METHOD <- toupper(verb) req$PATH_INFO <- path req$QUERY_STRING <- qs req$rook.input <- list(read_lines = function(){ body }) req } plumber/tests/testthat/test-image.R0000644000176200001440000000330513304040260017075 0ustar liggesuserscontext("Images") test_that("Images are properly rendered", { r <- plumber$new("files/image.R") resp <- r$serve(make_req("GET", "/png"), PlumberResponse$new()) expect_equal(resp$status, 200) expect_equal(resp$headers$`Content-type`, "image/png") fullsizePNG <- length(resp$body) expect_gt(fullsizePNG, 1000) # This changes based on R ver/OS, may not be useful. resp <- r$serve(make_req("GET", "/littlepng"), PlumberResponse$new()) expect_equal(resp$status, 200) expect_equal(resp$headers$`Content-type`, "image/png") expect_gt(length(resp$body), 100) # This changes based on R ver/OS, may not be useful. expect_lt(length(resp$body), fullsizePNG) # Should be smaller than the full one resp <- r$serve(make_req("GET", "/jpeg"), PlumberResponse$new()) expect_equal(resp$status, 200) expect_equal(resp$headers$`Content-type`, "image/jpeg") fullsizeJPEG <- length(resp$body) expect_gt(fullsizeJPEG, 1000) # This changes based on R ver/OS, may not be useful. resp <- r$serve(make_req("GET", "/littlejpeg"), PlumberResponse$new()) expect_equal(resp$status, 200) expect_equal(resp$headers$`Content-type`, "image/jpeg") expect_gt(length(resp$body), 100) # This changes based on R ver/OS, may not be useful. expect_lt(length(resp$body), fullsizeJPEG) # Should be smaller than the full one }) test_that("render_image arguments supplement", { pngcalls <- NULL mypng <- function(...){ pngcalls <<- list(...) } p <- render_image(mypng, "ct", list(a=1, b=2)) data <- new.env() req <- make_req("GET", "/") res <- list() p$pre(req, res, data) expect_length(pngcalls, 3) expect_equal(pngcalls$filename, data$file) expect_equal(pngcalls$a, 1) expect_equal(pngcalls$b, 2) }) plumber/tests/testthat/helper-compare-serializer.R0000644000176200001440000000173613304040260022116 0ustar liggesusers# We can't naively compare serializers using expect equal without losing codecov results. # codecov modifies the source of the functions so they are no longer comparable when # deparsed, which causes the tests to fail only for codecov. # Here we'll make our own comparison function. # covr adds lines to measure coverage but also adds brackets to capture expressions differently. # So we use this rough heuristic to just take the word characters without whitespace and compare # those. It's not perfect, but it would almost always fail if you were comparing to different # functions. expect_equal_functions <- function(object, expected){ do <- deparse(object) de <- deparse(expected) do <- gsub(".*covr:::count.*", NA, do) do <- do[!is.na(do)] do <- paste(do, collapse="") do <- gsub("[^\\w]", "", do, perl=TRUE) de <- gsub(".*covr:::count.*", NA, de) de <- de[!is.na(de)] de <- paste(de, collapse="") de <- gsub("[^\\w]", "", de, perl=TRUE) expect_equal(do, de) } plumber/tests/testthat/test-response.R0000644000176200001440000000164513304040260017656 0ustar liggesuserscontext("Responses") test_that("response properly sets basic cookies", { res <- PlumberResponse$new() res$setCookie("abc", "two words") head <- res$toResponse()$headers expect_equal(head[["Set-Cookie"]], "abc=two%20words") }) test_that("response sets non-char cookies", { res <- PlumberResponse$new() res$setCookie("abc", 123) head <- res$toResponse()$headers expect_equal(head[["Set-Cookie"]], "abc=123") }) test_that("can set multiple same-named headers", { res <- PlumberResponse$new() res$setHeader("head", "test") res$setHeader("head", "another") test <- FALSE another <- FALSE pres <- res$toResponse() for (i in 1:length(pres$headers)){ n <- names(pres$headers)[i] if (n == "head"){ if (pres$headers[[i]] == "test"){ test <- TRUE } else if (pres$headers[[i]] == "another"){ another <- TRUE } } } expect_true(test) expect_true(another) }) plumber/NAMESPACE0000644000176200001440000000155013304040260013130 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(PlumberEndpoint) export(PlumberStatic) export(addSerializer) export(do_configure_https) export(do_deploy_api) export(do_forward) export(do_provision) export(do_remove_api) export(do_remove_forward) export(forward) export(include_file) export(include_html) export(include_md) export(include_rmd) export(plumb) export(plumber) export(serializer_content_type) export(serializer_html) export(serializer_htmlwidget) export(serializer_json) export(serializer_unboxed_json) export(sessionCookie) import(R6) import(crayon) import(stringi) importFrom(grDevices,dev.off) importFrom(grDevices,jpeg) importFrom(grDevices,png) importFrom(httpuv,runServer) importFrom(jsonlite,fromJSON) importFrom(stats,runif) importFrom(utils,URLdecode) importFrom(utils,URLencode) importFrom(utils,compareVersion) importFrom(utils,packageVersion) plumber/NEWS.md0000644000176200001440000002262413305306110013014 0ustar liggesusersplumber 0.4.6 -------------------------------------------------------------------------------- * BUGFIX: Hooks that accept a `value` argument (`postroute`, `preserialize`, and `postserialize`) now modify the incoming value as documented. * BUGFIX: The `postserialize` hook is now given the serialized data as its `value` parameter. * BUGFIX: properly handle cookie expiration values ([#216](https://github.com/trestletech/plumber/issues/216)). * Add support for tags in Swagger docs ([#230](https://github.com/trestletech/plumber/pull/230)). * Optional `swaggerCallback` parameter for `run()` to supply a callback function for reporting the url for swagger page. * Add [RStudio Project Template](https://rstudio.github.io/rstudio-extensions/rstudio_project_templates.html) to package plumber 0.4.4 -------------------------------------------------------------------------------- * Support Expiration, HTTPOnly, and Secure flags on cookies (#87). **EDIT**: see [#216](https://github.com/trestletech/plumber/issues/216) which prevented expiration from working. * BUGFIX: properly handle named query string and post body arguments in mounted subrouters. * Added support for static sizing of images. `@png` and `@jpeg` now accept a parenthetical list of arguments that will be passed into the `png()` or `jpeg()` call. This enables annotations like `#' @png (width = 200, height=500)`. * Enable `ByteCompile` flag * Set working directory for DigitalOcean APIs. * Respect `setErrorHandler` * BUGFIX: export `PlumberStatic` * Case-insensitive matching on `plumber.r` and `entrypoint.r` when `plumb()`ing a directory. * Support query strings with keys that appear more than once ([#165](https://github.com/trestletech/plumber/pull/165)) * Fix the validation error warning at the bottom of deployed Swagger files which would have appeared any time your `swagger.json` file was hosted in such a way that a hosted validator service would not have been able to access it. For now we just suppress validation of swagger.json files. (#149) * Support for floating IPs in DNS check that occurs in `do_configure_https()` * Make adding swap file idempotent in `do_provision()` so you can now call that on a single droplet multiple times. * Support an `exit` hook which can define a function that will be evaluated when the API is interrupted. e.g. `pr <- plumb("plumber.R"); pr$registerHook("exit", function(){ print("Bye bye!") })` * Fixed bug in which a single function couldn't support multiple paths for a single verb (#203). * Support negative numbers in numeric path segments (#212) * Support `.` in string path segments plumber 0.4.2 -------------------------------------------------------------------------------- * Development version for 0.4.2. Will be working to move to even/odd release cycles, but I had prematurely bumped to 0.4.0 so that one might get skipped, making the next CRAN release 0.4.2. plumber 0.4.0 -------------------------------------------------------------------------------- * BREAKING: Listen on localhost instead of listening publicly by default. * BREAKING: We no longer set the `Access-Control-Allow-Origin` HTTP header to `*`. This was previously done for convenience but we've decided to prioritize security here by removing this default. You can still add this header to any route you want to be accessible from other origins. * BREAKING: Listen on a random port by default instead of always on 8000. This can be controlled using the `port` parameter in `run()`, or by setting the `plumber.port` option. * BREAKING: Removed `PlumberProcessor` class and replaced with a notion of hooks. See `registerHook` and `registerHooks` on the Plumber router. * BREAKING: `addGlobalProcessor` method on Plumber routers now takes a list which are added as hooks instead of a Processor. Note that `sessionCookie` has also been updated to behave accordingly, meaning that the convention of `pr$addGlobalProcessor(sessionCookie("secret", "cookieName"))` will continue to work for this release. * BREAKING: `sessionCookie` now returns a list instead of a Processor. Note that `addGlobalProcessor` has also been updated to behave accordingly, meaning that the convention of `pr$addGlobalProcessor(sessionCookie("secret", "cookieName"))` will continue to work for this release. * DEPRECATION: Deprecated the `addAssets` method on Plumber routers. Use `PlumberStatic` and the `mount` method to attach a static router. * DEPRECATION: Deprecated the `addEndpoint` method in favor of the `handle` method for Plumber routers. Removed support for the `processors`, `params`, and `comments` parameters are no longer supported. * DEPRECATION: Deprecated the `addFilter` method on Plumber routers in favor of the new `filter` method. Removed support for the processor parameter. * DEPRECATION: Deprecated the `addGlobalProcessor` method on Plumber routers. * The undocumented `setDefaultErrorHandler` method on Plumber routers now takes a function that returns the error handler function. The top-level function takes a single param named `debug` which is managed by the `debug` parameter in the `run()` method. * Added support for `OPTIONS` HTTP requests via the `@options` annotation. * Add support for `entrypoint.R` when `plumb()`ing a directory. If this file exists, it is expected to return a Plumber router representing the API contained in this directory. If it doesn't exist, the behavior is unaltered. If both `plumber.R` and `entrypoint.R` exist, `entrypoint.R` takes precedence. * `plumb()` the current directory by default if no arguments are provided. * Added a `debug` parameter to the `run` method which can be set to `TRUE` in order to get more insight into your API errors. plumber 0.3.3 -------------------------------------------------------------------------------- * `plumb()` now accepts an argument `dir`, referring to a directory containing `plumber.R`, which may be provided instead of `file`. plumber 0.3.2 -------------------------------------------------------------------------------- * Introduced the `do_provision()`, `do_deploy_api()`, `do_remove_api()` and `do_configure_https()` functions to provision and manage your APIs on a cloud server running on DigitalOcean. * `source()` the referenced R file to plumb inside of a new environment that inherits directly from the GlobalEnv. This provides more explicit control over exactly how this environment should behave. * Added `@serializer htmlwidget` to support rendering and returning a self-contained htmlwidget from a plumber endpoint. * Properly handle cookies with no value. (#88) * Don't convert `+` character in a query string to a space. plumber 0.3.1 -------------------------------------------------------------------------------- * Add a method to consume JSON on post (you can still send a query string in the body of a POST request as well). plumber 0.3.0 -------------------------------------------------------------------------------- * BREAKING CHANGE: serializer factories are now registered instead of the serializer themselves. Thus, `addSerializer()` now expects a function that returns a serializer, and `Response$new()` now expects a serializer itself rather than a character string naming a serializer. Internally it is the serializer itself that is attached to the response rather than the name of the serializer. This allows for a serializer to customize its behavior. * Accept an additional argument on the `@serializer` annotation -- R code that will be passed in as an argument to the serializer factory. See example `09-content-type`. plumber 0.2.4 -------------------------------------------------------------------------------- * Add a filter which parses and sets req$cookies to be a list corresponding to the cookies provided with the request. * Responses can set multiple cookies * Bug Fix: convert non-character arguments in setCookie to character before URL- encoding. plumber 0.2.3 -------------------------------------------------------------------------------- * Set options(warn=1) during execution of user code so that warnings are immediately visible in the console, rather than storing them until the server is stopped. plumber 0.2.2 -------------------------------------------------------------------------------- * Add `sessionCookie` function to define a processor that can be used as a globalProcessor on a router to encrypt values from req$session and store them as an encrypted cookie in on the user's browser. * Added `setCookie` method to response which (primitively) allows you to set a cookie to be included in the response. * Add `addGlobalProcessor` method on `plumber` class to support a processor that runs a processor only a single time, before and then after all other filters and the endpoint. * Document all public params so CHECK passes plumber 0.2.1 -------------------------------------------------------------------------------- * Add more Roxygen documentation for exported functions * Remove the warning in the README as the API seems to be stabilizing. plumber 0.2.0 -------------------------------------------------------------------------------- * BREAKING: Changed variable-path routing to use bracketed format instead of just a colon. * BREAKING: Renamed `PlumberRouter` R6 object to just `Plumber`. * Support `addEndpoint()` and `addFilter()` on the `Plumber` object. * Added support for the `#*` prefix. plumber 0.1.0 -------------------------------------------------------------------------------- * Initial Release plumber/R/0000755000176200001440000000000013305305241012115 5ustar liggesusersplumber/R/plumber-static.R0000644000176200001440000000425313304040260015173 0ustar liggesusers #' Static file router #' #' Creates a router that is backed by a directory of files on disk. #' @include plumber.R #' @export PlumberStatic <- R6Class( "plumberstatic", inherit = plumber, public = list( initialize = function(direc, options){ super$initialize(filters=NULL) private$dir <- direc if(missing(direc)){ stop("Cannot add asset directory when no directory was specified") } # Relative paths if(substr(direc, 1, 2) == "./"){ direc <- substr(direc, 3, nchar(direc)) } if (missing(options)){ options <- list() } # Evaluate to convert to list if (is.function(options)){ options <- options() } else if (is.expression(options)){ options <- eval(options, private$envir) } badRequest <- function(res){ res$body <- "

Bad Request

" res$status <- 400 res } expr <- function(req, res){ # Adapted from shiny:::staticHandler if (!identical(req$REQUEST_METHOD, 'GET')){ return(badRequest(res)) } path <- req$PATH_INFO if (is.null(path)){ return(badRequest(res)) } if (path == '/'){ path <- '/index.html' } abs.path <- resolve(direc, path) if (is.null(abs.path)){ # TODO: Should this be inherited from a parent router? val <- private$notFoundHandler(req=req, res=res) return(val) } ext <- tools::file_ext(abs.path) contentType <- getContentType(ext) responseContent <- readBin(abs.path, 'raw', n=file.info(abs.path)$size) res$status <- 200 res$setHeader("Content-type", contentType) res$body <- responseContent res } filter <- PlumberFilter$new(paste("static-asset", direc, sep="|"), expr, private$envir) private$addFilterInternal(filter) }, print = function(prefix="", topLevel=TRUE, ...){ cat(prefix) if (!topLevel){ cat("\u2502 ") } cat(crayon::silver("# Plumber static router serving from directory:", private$dir, "\n")) } ), private=list( dir = NULL ) ) plumber/R/query-string.R0000644000176200001440000000547313304040260014716 0ustar liggesusersqueryStringFilter <- function(req){ handled <- req$.internal$queryStringHandled if (is.null(handled) || handled != TRUE){ qs <- req$QUERY_STRING args <- parseQS(qs) req$args <- c(req$args, args) req$.internal$queryStringHandled <- TRUE } forward() } #' @importFrom utils URLdecode #' @noRd parseQS <- function(qs){ if (is.null(qs) || length(qs) == 0 || qs == "") { return(list()) } if (stri_startswith_fixed(qs, "?")) { qs <- substr(qs, 2, nchar(qs)) } parts <- strsplit(qs, "&", fixed = TRUE)[[1]] kv <- strsplit(parts, "=", fixed = TRUE) kv <- kv[sapply(kv, length) == 2] # Ignore incompletes keys <- sapply(kv, "[[", 1) keys <- unname(sapply(keys, URLdecode)) vals <- sapply(kv, "[[", 2) vals[is.na(vals)] <- "" vals <- unname(sapply(vals, URLdecode)) ret <- as.list(vals) names(ret) <- keys # If duplicates, combine combine_elements <- function(name){ unname(unlist(ret[names(ret)==name])) } unique_names <- unique(names(ret)) ret <- lapply(unique_names, combine_elements) names(ret) <- unique_names ret } createPathRegex <- function(pathDef){ # Create a regex from the defined path, substituting variables where appropriate match <- stringi::stri_match_all(pathDef, regex="/<(\\.?[a-zA-Z][\\w_\\.]*)(:(int|double|numeric|bool|logical))?>")[[1]] names <- match[,2] type <- match[,4] if (length(names) <= 1 && is.na(names)){ names <- character() type <- NULL } typedRe <- typeToRegex(type) re <- pathDef for (r in typedRe){ repl <- paste0("/(", r, ")$2") re <- stringi::stri_replace_first_regex(re, pattern="/(<\\.?[a-zA-Z][\\w_\\.:]*>)(/?)", replacement=repl) } converters <- typeToConverters(type) list(names = names, types=type, regex = paste0("^", re, "$"), converters=converters) } typeToRegex <- function(type){ re <- rep("[^/]+", length(type)) re[type == "int"] <- "-?\\\\d+" re[type == "double" | type == "numeric"] <- "-?\\\\d*\\\\.?\\\\d+" re[type == "bool" | type == "logical"] <- "[01tfTF]|true|false|TRUE|FALSE" re } typeToConverters <- function(type){ re <- NULL for (t in type){ r <- function(x){x} if (!is.na(t)){ if (t == "int"){ r <- as.integer } else if (t == "double" || t == "numeric"){ r <- as.numeric } else if (t == "bool" || t == "logical"){ r <- as.logical } } re <- c(re, r) } re } # Extract the params from a given path # @param def is the output from createPathRegex extractPathParams <- function(def, path){ vals <- as.list(stringi::stri_match(path, regex = def$regex)[,-1]) names(vals) <- def$names if (!is.null(def$converters)){ # Run each value through its converter for (i in 1:length(vals)){ vals[[i]] <- def$converters[[i]](vals[[i]]) } } vals } plumber/R/cookie-parser.R0000644000176200001440000000130313304040260014774 0ustar liggesuserscookieFilter <- function(req){ cookie <- req$HTTP_COOKIE req$cookies <- parseCookies(cookie) forward() } #' @importFrom utils URLdecode #' @noRd parseCookies <- function(cookie){ if (is.null(cookie) || nchar(cookie) == 0){ return(list()) } cookie <- strsplit(cookie, ";", fixed=TRUE)[[1]] cookie <- sub("\\s*([\\S*])\\s*", "\\1", cookie, perl=TRUE) cookieList <- strsplit(cookie, "=", fixed=TRUE) # Handle any non-existent cookie values. for (i in 1:length(cookieList)){ if(length(cookieList[[i]])==1){ cookieList[[i]][[2]] <- "" } } cookies <- lapply(cookieList, "[[", 2) names(cookies) <- sapply(cookieList, "[[", 1) return(lapply(cookies, URLdecode)) } plumber/R/serializer-xml.R0000644000176200001440000000067113304040260015207 0ustar liggesusersxmlSerializer <- function(){ function(val, req, res, errorHandler){ #if (!requireNamespace("XML", quietly = TRUE)) { # stop("The XML package is not available but is required in order to use the XML serializer.", # call. = FALSE) #} stop("XML serialization not yet implemented. Please see the discussion at https://github.com/trestletech/plumber/issues/65") } } .globals$serializers[["xml"]] <- xmlSerializer plumber/R/digital-ocean.R0000644000176200001440000004636613305334530014762 0ustar liggesusers # can't really test these. # nocov start checkAnalogSea <- function(){ if (!requireNamespace("analogsea", quietly = TRUE)) { stop("The analogsea package is not available but is required in order to use the provisioning functions. Please install analogsea.", call. = FALSE) } } #' Provision a DigitalOcean plumber server #' #' Create (if required), install the necessary prerequisites, and #' deploy a sample plumber application on a DigitalOcean virtual machine. #' You may sign up for a Digital Ocean account [here](https://m.do.co/c/add0b50f54c4). #' This command is idempotent, so feel free to run it on a single server multiple times. #' @param droplet The DigitalOcean droplet that you want to provision (see [analogsea::droplet()]). If empty, a new DigitalOcean server will be created. #' @param unstable If `FALSE`, will install plumber from CRAN. If `TRUE`, will install the unstable version of plumber from GitHub. #' @param example If `TRUE`, will deploy an example API named `hello` to the server on port 8000. #' @param ... Arguments passed into the [analogsea::droplet_create()] function. #' @details Provisions a Ubuntu 16.04-x64 droplet with the following customizations: #' - A recent version of R installed #' - plumber installed globally in the system library #' - An example plumber API deployed at `/var/plumber` #' - A systemd definition for the above plumber API which will ensure that the plumber #' API is started on machine boot and respawned if the R process ever crashes. On the #' server you can use commands like `systemctl restart plumber` to manage your API, or #' `journalctl -u plumber` to see the logs associated with your plumber process. #' - The `nginx`` web server installed to route web traffic from port 80 (HTTP) to your plumber #' process. #' - `ufw` installed as a firewall to restrict access on the server. By default it only #' allows incoming traffic on port 22 (SSH) and port 80 (HTTP). #' - A 4GB swap file is created to ensure that machines with little RAM (the default) are #' able to get through the necessary R package compilations. #' @export do_provision <- function(droplet, unstable=FALSE, example=TRUE, ...){ checkAnalogSea() if (missing(droplet)){ # No droplet provided; create a new server message("THIS ACTION COSTS YOU MONEY!") message("Provisioning a new server for which you will get a bill from DigitalOcean.") createArgs <- list(...) createArgs$tags <- c(createArgs$tags, "plumber") createArgs$image <- "ubuntu-16-04-x64" droplet <- do.call(analogsea::droplet_create, createArgs) # Wait for the droplet to come online analogsea::droplet_wait(droplet) # I often still get a closed port after droplet_wait returns. Buffer for just a bit Sys.sleep(25) # Refresh the droplet; sometimes the original one doesn't yet have a network interface. droplet <- analogsea::droplet(id=droplet$id) } # Provision lines <- droplet_capture(droplet, 'swapon | grep "/swapfile" | wc -l') if (lines != "1"){ analogsea::debian_add_swap(droplet) } install_new_r(droplet) install_plumber(droplet, unstable) install_api(droplet) install_nginx(droplet) install_firewall(droplet) if (example){ do_deploy_api(droplet, "hello", system.file("examples", "10-welcome", package="plumber"), port=8000, forward=TRUE) } invisible(droplet) } install_plumber <- function(droplet, unstable){ if (unstable){ analogsea::debian_apt_get_install(droplet, "libcurl4-openssl-dev") analogsea::debian_apt_get_install(droplet, "libgit2-dev") analogsea::debian_apt_get_install(droplet, "libssl-dev") analogsea::install_r_package(droplet, "devtools", repo="https://cran.rstudio.com") analogsea::droplet_ssh(droplet, "Rscript -e \"devtools::install_github('trestletech/plumber')\"") } else { analogsea::install_r_package(droplet, "plumber") } } #' Captures the output from running some command via SSH #' @noRd droplet_capture <- function(droplet, command){ tf <- tempfile() randName <- paste(sample(c(letters, LETTERS), size=10, replace=TRUE), collapse="") analogsea::droplet_ssh(droplet, paste0(command, " > /tmp/", randName)) analogsea::droplet_download(droplet, paste0("/tmp/", randName), tf) analogsea::droplet_ssh(droplet, paste0("rm /tmp/", randName)) lin <- readLines(tf) file.remove(tf) lin } install_api <- function(droplet){ analogsea::droplet_ssh(droplet, "mkdir -p /var/plumber") analogsea::droplet_upload(droplet, local=normalizePath( paste0(system.file("examples", "10-welcome", package="plumber"), "/**"), mustWork=FALSE), #TODO: Windows support for **? remote="/var/plumber/", verbose = TRUE) } install_firewall <- function(droplet){ analogsea::droplet_ssh(droplet, "ufw allow http") analogsea::droplet_ssh(droplet, "ufw allow ssh") analogsea::droplet_ssh(droplet, "ufw -f enable") } install_nginx <- function(droplet){ analogsea::debian_apt_get_install(droplet, "nginx") analogsea::droplet_ssh(droplet, "rm -f /etc/nginx/sites-enabled/default") # Disable the default site analogsea::droplet_ssh(droplet, "mkdir -p /var/certbot") analogsea::droplet_ssh(droplet, "mkdir -p /etc/nginx/sites-available/plumber-apis/") analogsea::droplet_upload(droplet, local=system.file("server", "nginx.conf", package="plumber"), remote="/etc/nginx/sites-available/plumber") analogsea::droplet_ssh(droplet, "ln -sf /etc/nginx/sites-available/plumber /etc/nginx/sites-enabled/") analogsea::droplet_ssh(droplet, "systemctl reload nginx") } install_new_r <- function(droplet){ analogsea::droplet_ssh(droplet, c("echo 'deb https://cran.rstudio.com/bin/linux/ubuntu xenial/' >> /etc/apt/sources.list", "apt-key adv --keyserver keyserver.ubuntu.com --recv-keys E084DAB9")) # TODO: use the analogsea version once https://github.com/sckott/analogsea/issues/139 is resolved #analogsea::debian_apt_get_update(droplet) analogsea::droplet_ssh(droplet, "sudo apt-get update -qq", 'sudo DEBIAN_FRONTEND=noninteractive apt-get -y -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" upgrade') analogsea::debian_install_r(droplet) } #' Add HTTPS to a plumber Droplet #' #' Adds TLS/SSL (HTTPS) to a droplet created using [do_provision()]. #' #' In order to get a TLS/SSL certificate, you need to point a domain name to the #' IP address associated with your droplet. If you don't already have a domain #' name, you can register one [here](http://tres.tl/domain). Point a (sub)domain #' to the IP address associated with your plumber droplet before calling this #' function. These changes may take a few minutes or hours to propagate around #' the Internet, but once complete you can then execute this function with the #' given domain to be granted a TLS/SSL certificate for that domain. #' @details Obtains a free TLS/SSL certificate from #' [letsencrypt](https://letsencrypt.org/) and installs it in nginx. It also #' configures nginx to route all unencrypted HTTP traffic (port 80) to HTTPS. #' Your TLS certificate will be automatically renewed and deployed. It also #' opens port 443 in the firewall to allow incoming HTTPS traffic. #' #' Historically, HTTPS certificates required payment in advance. If you #' appreciate this service, consider [donating to the letsencrypt #' project](https://letsencrypt.org/donate/). #' @param droplet The droplet on which to act. See [analogsea::droplet()]. #' @param domain The domain name associated with this instance. Used to obtain a #' TLS/SSL certificate. #' @param email Your email address; given only to letsencrypt when requesting a #' certificate to enable them to contact you about issues with renewal or #' security. #' @param termsOfService Set to `TRUE` to agree to the letsencrypt subscriber #' agreement. At the time of writing, the current version is available [here](https://letsencrypt.org/documents/LE-SA-v1.1.1-August-1-2016.pdf). #' Must be set to true to obtain a certificate through letsencrypt. #' @param force If `FALSE`, will abort if it believes that the given domain name #' is not yet pointing at the appropriate IP address for this droplet. If #' `TRUE`, will ignore this check and attempt to proceed regardless. #' @importFrom jsonlite fromJSON #' @export do_configure_https <- function(droplet, domain, email, termsOfService=FALSE, force=FALSE){ checkAnalogSea() # This could be done locally, but I don't have a good way of testing cross-platform currently. # I can't figure out how to capture the output of the system() call inside # of droplet_ssh, so just write to and download a file :\ if (!force){ nslookup <- tempfile() nsout <- droplet_capture(droplet, paste0("nslookup ", domain)) ips <- nsout[grepl("^Address: ", nsout)] ip <- gsub("^Address: (.*)$", "\\1", ips) # It turns out that the floating IP is not data that we have about the droplet # Also, if the floating IP was assigned after we created the droplet object that was # passed in, then we might not have that information available anyways. # It turns out that we can use the 'Droplet Metadata' system to query for this info # from the droplet to get a real-time response. metadata <- droplet_capture(droplet, "curl http://169.254.169.254/metadata/v1.json") parsed <- jsonlite::fromJSON(metadata) floating <- unlist(lapply(parsed$floating_ip, function(ipv){ ipv$ip_address })) ephemeral <- unlist(parsed$interfaces$public)["ipv4.ip_address"] if (ip %in% ephemeral) { warning("You should consider using a Floating IP address on your droplet for DNS. Currently ", "you're using the ephemeral IP address of your droplet for DNS which is dangerous; ", "as soon as you terminate your droplet your DNS records will be pointing to an IP ", "address you no longer control. A floating IP will give you the opportunity to ", "create a new droplet and reassign the floating IP used with DNS later.") } else if (! ip %in% floating) { print(list(ip=ip, floatingIPs = unname(floating), ephemeralIPs = unname(ephemeral))) stop("It doesn't appear that the domain name '", domain, "' is pointed to an IP address associated with this droplet. ", "This could be due to a DNS misconfiguration or because the changes just haven't propagated through the Internet yet. ", "If you believe this is an error, you can override this check by setting force=TRUE.") } message("Confirmed that '", domain, "' references one of the available IP addresses.") } if(missing(domain)){ stop("You must provide a valid domain name which points to this server in order to get an SSL certificate.") } if (missing(email)){ stop("You must provide an email to letsencrypt -- the provider of your SSL certificate -- for 'urgent renewal and security notices'.") } if (!termsOfService){ stop("You must agree to the letsencrypt terms of service before running this function") } # Trim off any protocol prefix if one exists domain <- sub("^https?://", "", domain) # Trim off any trailing slash if one exists. domain <- sub("/$", "", domain) # Prepare the nginx conf file. conf <- readLines(system.file("server", "nginx-ssl.conf", package="plumber")) conf <- gsub("\\$DOMAIN\\$", domain, conf) conffile <- tempfile() writeLines(conf, conffile) analogsea::droplet_ssh(droplet, "add-apt-repository ppa:certbot/certbot") analogsea::debian_apt_get_update(droplet) analogsea::debian_apt_get_install(droplet, "certbot") analogsea::droplet_ssh(droplet, "ufw allow https") analogsea::droplet_ssh(droplet, sprintf("certbot certonly --webroot -w /var/certbot/ -n -d %s --email %s --agree-tos --renew-hook '/bin/systemctl reload nginx'", domain, email)) analogsea::droplet_upload(droplet, conffile, "/etc/nginx/sites-available/plumber") analogsea::droplet_ssh(droplet, "systemctl reload nginx") # TODO: add this as a catch() file.remove(conffile) invisible(droplet) } #' Deploy or Update an API #' #' Deploys an API from your local machine to make it available on the remote #' plumber server. #' @param droplet The droplet on which to act. It's expected that this droplet #' was provisioned using [do_provision()]. See [analogsea::droplet()] to #' obtain a reference to a running droplet. #' @param path The remote path/name of the application #' @param localPath The local path to the API that you want to deploy. The #' entire directory referenced will be deployed, and the `plumber.R` file #' inside of that directory will be used as the root plumber file. The #' directory MUST contain a `plumber.R` file. #' @param port The internal port on which this service should run. This will not #' be user visible, but must be unique and point to a port that is available #' on your server. If unsure, try a number around `8000`. #' @param forward If `TRUE`, will setup requests targeting the root URL on the #' server to point to this application. See the [do_forward()] function for #' more details. #' @param swagger If `TRUE`, will enable the Swagger interface for the remotely #' deployed API. By default, the interface is disabled. #' @param preflight R commands to run after [plumb()]ing the `plumber.R` file, #' but before `run()`ing the plumber service. This is an opportunity to e.g. #' add new filters. If you need to specify multiple commands, they should be #' semi-colon-delimited. #' @export do_deploy_api <- function(droplet, path, localPath, port, forward=FALSE, swagger=FALSE, preflight){ # Trim off any leading slashes path <- sub("^/+", "", path) # Trim off any trailing slashes if any exist. path <- sub("/+$", "", path) if (grepl("/", path)){ stop("Can't deploy to nested paths. '", path, "' should not have a / in it.") } # TODO: check local path for plumber.R file. apiPath <- file.path(localPath, "plumber.R") if (!file.exists(apiPath)){ stop("Your local API must contain a `plumber.R` file. ", apiPath, " does not exist") } ### UPLOAD the API ### localPath <- sub("/+$", "", localPath) analogsea::droplet_ssh(droplet, paste0("mkdir -p /var/plumber/", path)) analogsea::droplet_upload(droplet, local=paste0(localPath, "/**"), #TODO: Windows support for **? remote=paste0("/var/plumber/", path, "/")) ### SYSTEMD ### serviceName <- paste0("plumber-", path) service <- readLines(system.file("server", "plumber.service", package="plumber")) service <- gsub("\\$PORT\\$", port, service) service <- gsub("\\$PATH\\$", paste0("/", path), service) if (missing(preflight)){ preflight <- "" } else { # Append semicolon if necessary if (!grepl(";\\s*$", preflight)){ preflight <- paste0(preflight, ";") } } service <- gsub("\\$PREFLIGHT\\$", preflight, service) if (missing(swagger)){ swagger <- "FALSE" } else { swagger <- "TRUE" } service <- gsub("\\$SWAGGER\\$", swagger, service) servicefile <- tempfile() writeLines(service, servicefile) remotePath <- file.path("/etc/systemd/system", paste0(serviceName, ".service")) analogsea::droplet_upload(droplet, servicefile, remotePath) analogsea::droplet_ssh(droplet, "systemctl daemon-reload") # TODO: add this as a catch() file.remove(servicefile) # TODO: differentiate between new service (start) and existing service (restart) analogsea::droplet_ssh(droplet, paste0("systemctl start ", serviceName, " && sleep 1")) #TODO: can systemctl listen for the port to come online so we don't have to guess at a sleep value? analogsea::droplet_ssh(droplet, paste0("systemctl restart ", serviceName, " && sleep 1")) analogsea::droplet_ssh(droplet, paste0("systemctl enable ", serviceName)) analogsea::droplet_ssh(droplet, paste0("systemctl status ", serviceName)) ### NGINX ### # Prepare the nginx conf file conf <- readLines(system.file("server", "plumber-api.conf", package="plumber")) conf <- gsub("\\$PORT\\$", port, conf) conf <- gsub("\\$PATH\\$", path, conf) conffile <- tempfile() writeLines(conf, conffile) remotePath <- file.path("/etc/nginx/sites-available/plumber-apis", paste0(path, ".conf")) analogsea::droplet_upload(droplet, conffile, remotePath) # TODO: add this as a catch() file.remove(conffile) if (forward){ do_forward(droplet, path) } analogsea::droplet_ssh(droplet, "systemctl reload nginx") } #' Forward Root Requests to an API #' #' @param droplet The droplet on which to act. It's expected that this droplet #' was provisioned using [do_provision()]. #' @param path The path to which root requests should be forwarded #' @export do_forward <- function(droplet, path){ # Trim off any leading slashes path <- sub("^/+", "", path) # Trim off any trailing slashes if any exist. path <- sub("/+$", "", path) if (grepl("/", path)){ stop("Can't deploy to nested paths. '", path, "' should not have a / in it.") } forward <- readLines(system.file("server", "forward.conf", package="plumber")) forward <- gsub("\\$PATH\\$", paste0(path), forward) forwardfile <- tempfile() writeLines(forward, forwardfile) analogsea::droplet_upload(droplet, forwardfile, "/etc/nginx/sites-available/plumber-apis/_forward.conf") # TODO: add this as a catch() file.remove(forwardfile) invisible(droplet) } #' Remove an API from the server #' #' Removes all services and routing rules associated with a particular service. #' Optionally purges the associated API directory from disk. #' @param droplet The droplet on which to act. It's expected that this droplet #' was provisioned using [do_provision()]. See [analogsea::droplet()] to #' obtain a reference to a running droplet. #' @param path The path/name of the plumber service #' @param delete If `TRUE`, will also delete the associated directory #' (`/var/plumber/whatever`) from the server. #' @export do_remove_api <- function(droplet, path, delete=FALSE){ # Trim off any leading slashes path <- sub("^/+", "", path) # Trim off any trailing slashes if any exist. path <- sub("/+$", "", path) if (grepl("/", path)){ stop("Can't deploy to nested paths. '", path, "' should not have a / in it.") } # Given that we're about to `rm -rf`, let's just be safe... if (grepl("\\.\\.", path)){ stop("Paths don't allow '..'s.") } if (nchar(path)==0){ stop("Path cannot be empty.") } serviceName <- paste0("plumber-", path) analogsea::droplet_ssh(droplet, paste0("systemctl stop ", serviceName)) analogsea::droplet_ssh(droplet, paste0("systemctl disable ", serviceName)) analogsea::droplet_ssh(droplet, paste0("rm /etc/systemd/system/", serviceName, ".service")) analogsea::droplet_ssh(droplet, paste0("rm /etc/nginx/sites-available/plumber-apis/", path, ".conf")) analogsea::droplet_ssh(droplet, "systemctl reload nginx") if(delete){ analogsea::droplet_ssh(droplet, paste0("rm -rf /var/plumber/", path)) } } #' Remove the forwarding rule #' #' Removes the forwarding rule from the root path on the server. The server will #' no longer forward requests for `/` to an application. #' @param droplet The droplet on which to act. It's expected that this droplet #' was provisioned using [do_provision()]. See [analogsea::droplet()] to obtain a reference to a running droplet. #' @export do_remove_forward <- function(droplet){ analogsea::droplet_ssh(droplet, "rm /etc/nginx/sites-available/plumber-apis/_forward.conf") analogsea::droplet_ssh(droplet, "systemctl reload nginx") } # nocov end plumber/R/post-body.R0000644000176200001440000000164413305305241014165 0ustar liggesuserspostBodyFilter <- function(req){ handled <- req$.internal$postBodyHandled if (is.null(handled) || handled != TRUE){ body <- req$rook.input$read_lines() charset <- getCharacterSet(req$HTTP_CONTENT_TYPE) args <- parseBody(body, charset) req$postBody <- body req$args <- c(req$args, args) req$.internal$postBodyHandled <- TRUE } forward() } #' @importFrom utils URLdecode #' @noRd parseBody <- function(body, charset = "UTF-8"){ # The body in a curl call can also include querystring formatted data # Is there data in the request? if (is.null(body) || length(body) == 0 || body == "") { return(list()) } if (is.character(body)) { Encoding(body) <- charset } # Is it JSON data? if (stri_startswith_fixed(body, "{")) { # Handle JSON with jsonlite ret <- jsonlite::fromJSON(body) } else { # If not handle it as a query string ret <- parseQS(body) } ret } plumber/R/serializer-htmlwidget.R0000644000176200001440000000241113305274406016565 0ustar liggesusers#' @include globals.R #' @rdname serializers #' @export serializer_htmlwidget <- function(){ function(val, req, res, errorHandler){ tryCatch({ if (!requireNamespace("htmlwidgets", quietly = TRUE)) { stop("The htmlwidgets package is not available but is required in order to use the htmlwidgets serializer", call. = FALSE) } # Set content type to HTML res$setHeader("Content-Type", "text/html; charset=utf-8") # Write out a temp file. htmlwidgets (or pandoc?) seems to require that this # file end in .html or the selfcontained=TRUE argument has no effect. file <- tempfile(fileext=".html") # Write the widget out to a file (doesn't currently support in-memory connections) # Must write a self-contained file. We're not serving a directory of assets # in response to this request, just one HTML file. htmlwidgets::saveWidget(val, file, selfcontained=TRUE) # Read the file back in as a single string and return. res$body <- paste(readLines(file), collapse="\n") # Delete the temp file file.remove(file) return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["htmlwidget"]] <- serializer_htmlwidget plumber/R/globals.R0000644000176200001440000000012613304040260013656 0ustar liggesusers.globals <- new.env() .globals$serializers <- list() .globals$processors <- new.env() plumber/R/serializer-content-type.R0000644000176200001440000000104413304040260017033 0ustar liggesusers#' @rdname serializers #' @param type The value to provide for the `Content-Type` HTTP header. #' @export serializer_content_type <- function(type){ if (missing(type)){ stop("You must provide the custom content type to the serializer_content_type") } function(val, req, res, errorHandler){ tryCatch({ res$setHeader("Content-Type", type) res$body <- val return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["contentType"]] <- serializer_content_type plumber/R/find-port.R0000644000176200001440000000261613304040260014143 0ustar liggesusers # Exclude unsafe ports from Chrome https://src.chromium.org/viewvc/chrome/trunk/src/net/base/net_util.cc?view=markup#l127 portBlacklist <- c(0, 3659, 4045, 6000, 6665, 6666, 6667, 6668, 6669) #' Get a random port between 3k and 10k, excluding the blacklist. If a preferred port #' has already been registered in .globals, use that instead. #' @importFrom stats runif #' @noRd getRandomPort <- function(){ port <- 0 while (port %in% portBlacklist){ port <- round(runif(1, 3000, 10000)) } port } #' Find a port either using the assigned port or randomly search 10 times for an available #' port. If a port was manually assigned, just return it and assume it will work. #' @noRd findPort <- function(port){ if (missing(port) || is.null(port)){ if (!is.null(.globals$port)){ # Start by trying the .globals$port port <- .globals$port } else { port <- getRandomPort() } for (i in 1:10){ tryCatch(srv <- httpuv::startServer("127.0.0.1", port, list()), error=function(e){ port <<- 0 }) if (port != 0){ # Stop the temporary server, and retain this port number. httpuv::stopServer(srv) .globals$port <- port break } port <- getRandomPort() } } if (port == 0){ stop("Unable to start a Plumber server. Either the port specified was unavailable or we were unable to find a free port.") } port } plumber/R/plumber-step.R0000644000176200001440000001122413304040260014653 0ustar liggesusers#' Forward Request to The Next Handler #' #' This function is used when a filter is done processing a request and wishes #' to pass control off to the next handler in the chain. If this is not called #' by a filter, the assumption is that the filter fully handled the request #' itself and no other filters or endpoints should be evaluated for this #' request. #' @export forward <- function(){ .globals$forwarded <- TRUE } PlumberStep <- R6Class( "PlumberStep", inherit=hookable, public = list( lines = NA, serializer = NULL, initialize = function(expr, envir, lines, serializer){ private$expr <- expr if (is.expression(expr)){ private$func <- eval(expr, envir) } else { private$func <- expr } private$envir <- envir if (!missing(lines)){ self$lines <- lines } if (!missing(serializer)){ self$serializer <- serializer } }, exec = function(...){ args <- getRelevantArgs(list(...), plumberExpression=private$expr) hookEnv <- new.env() private$runHooks("preexec", c(list(data=hookEnv), list(...))) val <- do.call(private$func, args, envir=private$envir) val <- private$runHooks("postexec", c(list(data=hookEnv, value=val), list(...))) val }, registerHook = function(stage=c("preexec", "postexec"), handler){ stage <- match.arg(stage) super$registerHook(stage, handler) } ), private = list( envir = NA, expr = NA, func = NA ) ) # @param positional list with names where they were provided. getRelevantArgs <- function(args, plumberExpression){ if (length(args) == 0){ unnamedArgs <- NULL } else if (is.null(names(args))){ unnamedArgs <- 1:length(args) } else { unnamedArgs <- which(names(args) == "") } if (length(unnamedArgs) > 0 ){ stop("Can't call a Plumber function with unnammed arguments. Missing names for argument(s) #", paste0(unnamedArgs, collapse=", "), ". Names of argument list was: \"", paste0(names(args), collapse=","), "\"") } # Extract the names of the arguments this function supports. fargs <- names(formals(eval(plumberExpression))) if (!"..." %in% fargs){ # Use the named arguments that match, drop the rest. args <- args[names(args) %in% fargs] } args } #' Plumber Endpoint #' #' Defines a terminal handler in a PLumber router. #' @export PlumberEndpoint <- R6Class( "PlumberEndpoint", inherit = PlumberStep, public = list( verbs = NA, path = NA, comments = NA, responses = NA, getTypedParams = function(){ data.frame(name=private$regex$names, type=private$regex$types) }, params = NA, tags = NA, canServe = function(req){ req$REQUEST_METHOD %in% self$verbs && !is.na(stringi::stri_match(req$PATH_INFO, regex=private$regex$regex)[1,1]) }, # For historical reasons we have to accept multiple verbs for a single path. Now it's simpler # to just parse each separate verb/path into its own endpoint, so we just do that. initialize = function(verbs, path, expr, envir, serializer, lines, params, comments, responses, tags){ self$verbs <- verbs self$path <- path private$regex <- createPathRegex(path) private$expr <- expr if (is.expression(expr)){ private$func <- eval(expr, envir) } else { private$func <- expr } private$envir <- envir if (!missing(serializer) && !is.null(serializer)){ self$serializer <- serializer } if (!missing(lines)){ self$lines <- lines } if (!missing(params)){ self$params <- params } if (!missing(comments)){ self$comments <- comments } if (!missing(responses)){ self$responses <- responses } if(!missing(tags) && !is.null(tags)){ # make sure we box tags in json using I() # single tags should be converted to json as: # tags: ["tagName"] and not tags: "tagName" self$tags <- I(tags) } }, getPathParams = function(path){ extractPathParams(private$regex, path) } ), private = list( regex = NULL ) ) PlumberFilter <- R6Class( "PlumberFilter", inherit = PlumberStep, public = list( name = NA, initialize = function(name, expr, envir, serializer, lines){ self$name <- name private$expr <- expr if (is.expression(expr)){ private$func <- eval(expr, envir) } else { private$func <- expr } private$envir <- envir if (!missing(serializer)){ self$serializer <- serializer } if (!missing(lines)){ self$lines <- lines } } ) ) plumber/R/default-handlers.R0000644000176200001440000000135713304040260015464 0ustar liggesusers#' @include plumber.R default404Handler <- function(req, res){ res$status <- 404 list(error="404 - Resource Not Found") } defaultErrorHandler <- function(){ function(req, res, err){ print(err) li <- list() if (res$status == 200L){ # The default is a 200. If that's still set, then we should probably override with a 500. # It's possible, however, than a handler set a 40x and then wants to use this function to # render an error, though. res$status <- 500 li$error <- "500 - Internal server error" } else { li$error <- "Internal error" } # Don't overly leak data unless they opt-in if (getOption('plumber.debug')){ li["message"] <- as.character(err) } li } } plumber/R/session-cookie.R0000644000176200001440000000450013304040260015165 0ustar liggesusers#' Store session data in encrypted cookies. #' @param key The secret key to use. This must be consistent across all sessions #' where you want to save/restore encrypted cookies. It should be a long and #' complex character string to bolster security. #' @param name The name of the cookie in the user's browser. #' @param ... Arguments passed on to the \code{response$setCookie} call to, #' for instance, set the cookie's expiration. #' @include plumber.R #' @export sessionCookie <- function(key, name="plumber", ...){ if (missing(key)){ stop("You must define an encryption key or set it to NULL to disable encryption") } if (!is.null(key)){ checkPKI() key <- PKI::PKI.digest(charToRaw(key), "SHA256") } # Return a list that can be added to registerHooks() list( preroute = function(req, res, data){ cookies <- req$cookies if (is.null(cookies)){ # The cookie-parser filter has probably not run yet. Parse the cookies ourselves # TODO: would be more performant not to run this cookie parsing twice. cookies <- parseCookies(req$HTTP_COOKIE) } session <- cookies[[name]] if (!is.null(session) && !identical(session, "")){ if (!is.null(key)){ tryCatch({ session <- base64enc::base64decode(session) session <- PKI::PKI.decrypt(session, key, "aes256") session <- rawToChar(session) session <- jsonlite::fromJSON(session) }, error=function(e){ warning("Error processing session cookie. Perhaps your secret changed?") session <<- NULL }) } } req$session <- session }, postroute = function(value, req, res, data){ if (!is.null(req$session)){ sess <- jsonlite::toJSON(req$session) if (!is.null(key)){ sess <- PKI::PKI.encrypt(charToRaw(sess), key, "aes256") sess <- base64enc::base64encode(sess) } res$setCookie(name, sess, ...) } value } ) } #' @importFrom utils packageVersion #' @importFrom utils compareVersion #' @noRd checkPKI <- function(){ pkiVer <- tryCatch({as.character(packageVersion("PKI"))}, error=function(e){"0.0.0"}); if (compareVersion(pkiVer, "0.1.2") < 0){ stop("You need PKI version 0.1.2 or greater installed.") } } plumber/R/images.R0000644000176200001440000000152313304040260013502 0ustar liggesusers#' @param imageFun The function to call to setup the image device (e.g. `png`) #' @param args A list of supplemental arguments to be passed into jpeg() #' @importFrom grDevices dev.off jpeg png #' @noRd render_image <- function(imageFun, contentType, args=NULL){ list( pre = function(req, res, data){ t <- tempfile() data$file <- t finalArgs <- c(list(filename=t), args) do.call(imageFun, finalArgs) }, post = function(value, req, res, data){ dev.off() con <- file(data$file, "rb") img <- readBin(con, "raw", file.info(data$file)$size) close(con) res$body <- img res$setHeader("Content-type", contentType) res } ) } render_jpeg <- function(args){ render_image(jpeg, "image/jpeg", args) } render_png <- function(args){ render_image(png, "image/png", args) } plumber/R/serializer.R0000644000176200001440000000252713304040260014413 0ustar liggesusers#' Plumber Serializers #' #' Serializers are used in Plumber to transform the R object produced by a #' filter/endpoint into an HTTP response that can be returned to the client. See #' [here](https://book.rplumber.io/rendering-and-output.html#serializers) for #' more details on Plumber serializers and how to customize their behavior. #' @name serializers #' @rdname serializers NULL #' Add a Serializer #' #' A serializer is responsible for translating a generated R value into output #' that a remote user can understand. For instance, the \code{serializer_json} #' serializes R objects into JSON before returning them to the user. The list of #' available serializers in plumber is global. #' #' @param name The name of the serializer (character string) #' @param serializer The serializer to be added. #' #' @export addSerializer <- function(name, serializer){ if (is.null(.globals$serializers)){ .globals$serializers <- list() } if (!is.null(.globals$serializers[[name]])){ stop ("Already have a serializer by the name of ", name) } .globals$serializers[[name]] <- serializer } nullSerializer <- function(){ function(val, req, res, errorHandler){ tryCatch({ res$body <- val return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["null"]] <- nullSerializer plumber/R/paths.R0000644000176200001440000000122013304040260013346 0ustar liggesusers# Taken from shiny # @author shiny authors resolve <- function(dir, relpath) { abs.path <- file.path(dir, relpath) if (!file.exists(abs.path)) return(NULL) abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE) dir <- normalizePath(dir, winslash='/', mustWork=TRUE) # trim the possible trailing slash under Windows (#306) if (isWindows()) dir <- sub('/$', '', dir) if (nchar(abs.path) <= nchar(dir) + 1) return(NULL) if (substr(abs.path, 1, nchar(dir)) != dir || substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') { return(NULL) } return(abs.path) } isWindows <- function() .Platform$OS.type == 'windows' plumber/R/serializer-html.R0000644000176200001440000000055113304040260015350 0ustar liggesusers#' @rdname serializers #' @export serializer_html <- function(){ function(val, req, res, errorHandler){ tryCatch({ res$setHeader("Content-Type", "text/html; charset=utf-8") res$body <- val return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["html"]] <- serializer_html plumber/R/parse-globals.R0000644000176200001440000000701713304040260014774 0ustar liggesusers #' Parse the given argument and extend the given fields list with new data. #' @param fields A list that contains at least an `info` sub-list. #' @param argument The line (including the plumber comment prefix) to append. #' If this line represents what was once multiple lines, intermediate comment #' prefixes should have been removed. #' @noRd parseOneGlobal <- function(fields, argument){ if (nchar(argument) == 0){ return(fields) } parsedLine <- regmatches(argument, regexec( argRegex, argument, ignore.case=TRUE))[[1]] if (length(parsedLine) != 4){ return(fields) } name <- parsedLine[3] def <- parsedLine[4] def <- gsub("^\\s*|\\s*$", "", def) switch(name, apiTitle={ fields$info$title <- def }, apiDescription={ fields$info$description <- def }, apiTOS={ fields$info$termsOfService <- def }, apiContact={ fields$info$contact <- def }, apiLicense={ fields$info$license <- def }, apiVersion={ fields$info$version <- def }, apiHost={ fields$host <- def }, apiBasePath={ fields$basePath <- def }, apiSchemes={ fields$schemes <- strsplit(def, split="\\s+")[[1]] }, apiConsumes={ fields$consumes <- strsplit(def, split="\\s+")[[1]] }, apiProduces={ fields$produces <- strsplit(def, split="\\s+")[[1]] }, apiTag={ tagMat <- stringi::stri_match(def, regex="^\\s*(\\w+)\\s+(\\S.+)\\s*$") name <- tagMat[1,2] description <- tagMat[1,3] if(!is.null(fields$tags) && name %in% fields$tags$name) { stop("Error: '", argument, "' - ","Duplicate tag definition specified.") } fields$tags <- rbind(fields$tags,data.frame(name=name, description=description, stringsAsFactors = FALSE)) }) fields } argRegex <- "^#['\\*]\\s*(@(api\\w+)\\s+)?(.*)$" #' Parse out the global API settings of a given set of lines and return a #' swagger-compliant list describing the global API. #' @noRd parseGlobals <- function(lines){ # Build up the entire argument here; needed since a single directive # might wrap multiple lines fullArg <- "" # Build up the fields that we want to return as globals fields <- list(info=list()) # Parse the global docs for (line in lines){ parsedLine <- regmatches(line, regexec( argRegex, line, ignore.case=TRUE))[[1]] if (length(parsedLine) == 4){ if (nchar(parsedLine[3]) == 0){ # Not a new argument, continue existing one fullArg <- paste(fullArg, parsedLine[4]) } else { # New argument, parse the buffer and start a new one fields <- parseOneGlobal(fields, fullArg) fullArg <- line } } else { # This isn't a line we can underestand. Parse what we have in the # buffer and then reset fields <- parseOneGlobal(fields, fullArg) fullArg <- "" } } # Clear out the buffer fields <- parseOneGlobal(fields, fullArg) fields } #' The default set of Swagger API globals. Some of these properties are subject #' to being overridden by @api* annotations. #' @noRd defaultGlobals <- list( swagger = "2.0", info = list(description="API Description", title="API Title", version="1.0.0"), host=NA, schemes= I("http"), produces=I("application/json") #securityDefinitions = list(), #definitions = list() ) plumber/R/content-types.R0000644000176200001440000000423013305305241015053 0ustar liggesusers# FROM Shiny # @author Shiny package authors knownContentTypes <- list( html='text/html; charset=UTF-8', htm='text/html; charset=UTF-8', js='text/javascript', css='text/css', png='image/png', jpg='image/jpeg', jpeg='image/jpeg', gif='image/gif', svg='image/svg+xml', txt='text/plain', pdf='application/pdf', ps='application/postscript', xml='application/xml', m3u='audio/x-mpegurl', m4a='audio/mp4a-latm', m4b='audio/mp4a-latm', m4p='audio/mp4a-latm', mp3='audio/mpeg', wav='audio/x-wav', m4u='video/vnd.mpegurl', m4v='video/x-m4v', mp4='video/mp4', mpeg='video/mpeg', mpg='video/mpeg', avi='video/x-msvideo', mov='video/quicktime', ogg='application/ogg', swf='application/x-shockwave-flash', doc='application/msword', xls='application/vnd.ms-excel', ppt='application/vnd.ms-powerpoint', xlsx='application/vnd.openxmlformats-officedocument.spreadsheetml.sheet', xltx='application/vnd.openxmlformats-officedocument.spreadsheetml.template', potx='application/vnd.openxmlformats-officedocument.presentationml.template', ppsx='application/vnd.openxmlformats-officedocument.presentationml.slideshow', pptx='application/vnd.openxmlformats-officedocument.presentationml.presentation', sldx='application/vnd.openxmlformats-officedocument.presentationml.slide', docx='application/vnd.openxmlformats-officedocument.wordprocessingml.document', dotx='application/vnd.openxmlformats-officedocument.wordprocessingml.template', xlam='application/vnd.ms-excel.addin.macroEnabled.12', xlsb='application/vnd.ms-excel.sheet.binary.macroEnabled.12') getContentType <- function(ext, defaultType='application/octet-stream') { ct <- knownContentTypes[[tolower(ext)]] if (is.null(ct)){ ct <- defaultType } return(ct) } getCharacterSet <- function(contentType){ default <- "UTF-8" if (is.null(contentType)) { return(default) } charsetStart <- attr( gregexpr(".*charset=(.*)", contentType, perl = T)[[1]], "capture.start" ) charsetStart <- as.integer(charsetStart) as.character( ifelse( charsetStart > -1, substr(contentType, charsetStart, nchar(contentType)), default ) ) } plumber/R/serializer-json.R0000644000176200001440000000154413304040260015360 0ustar liggesusers#' @include globals.R #' @rdname serializers #' @export serializer_json <- function(){ function(val, req, res, errorHandler){ tryCatch({ json <- jsonlite::toJSON(val) res$setHeader("Content-Type", "application/json") res$body <- json return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["json"]] <- serializer_json #' @include globals.R #' @rdname serializers #' @export serializer_unboxed_json <- function(){ function(val, req, res, errorHandler){ tryCatch({ json <- jsonlite::toJSON(val, auto_unbox = TRUE) res$setHeader("Content-Type", "application/json") res$body <- json return(res$toResponse()) }, error=function(e){ errorHandler(req, res, e) }) } } .globals$serializers[["unboxedJSON"]] <- serializer_unboxed_json plumber/R/plumber.R0000644000176200001440000005253013304040260013707 0ustar liggesusers#' @import R6 #' @import stringi NULL # used to identify annotation flags. verbs <- c("GET", "PUT", "POST", "DELETE", "HEAD", "OPTIONS", "PATCH") enumerateVerbs <- function(v){ if (identical(v, "use")){ return(verbs) } toupper(v) } #' @rdname plumber #' @export plumb <- function(file, dir="."){ dirMode <- NULL if (!missing(file) && !missing(dir)){ # Both were explicitly set. Error stop("You must set either the file or the directory parameter, not both") } else if (missing(file)){ if (identical(dir, "")){ # dir and file are both empty. Error stop("You must specify either a file or directory parameter") } # Parse dir dirMode <- TRUE dir <- sub("/$", "", dir) # Find plumber.R in the directory case-insensitively file <- list.files(dir, "^plumber\\.r$", ignore.case = TRUE, full.names = TRUE) if (length(file) == 0){ stop("No plumber.R file found in the specified directory: ", dir) } } else { # File was specified dirMode <- FALSE } entrypoint <- list.files(dir, "^entrypoint\\.r$", ignore.case = TRUE) if (dirMode && length(entrypoint) > 0){ # Dir was specified and we found an entrypoint.R old <- setwd(dir) on.exit(setwd(old)) # Expect that entrypoint will provide us with the router x <- source(entrypoint) # source returns a list with value and visible elements, we want the (visible) value object. pr <- x$value if (!("plumber" %in% class(pr))){ stop("entrypoint.R must return a runnable Plumber router.") } pr } else if (file.exists(file)) { # Plumber file found plumber$new(file) } else { # Couldn't find the Plumber file nor an entrypoint stop("File does not exist: ", file) } } #' @include query-string.R #' @include post-body.R #' @include cookie-parser.R #' @include shared-secret-filter.R defaultPlumberFilters <- list( queryString = queryStringFilter, postBody = postBodyFilter, cookieParser = cookieFilter, sharedSecret = sharedSecretFilter) hookable <- R6Class( "hookable", public=list( registerHook = function(stage, handler){ private$hooks[[stage]] <- c(private$hooks[[stage]], handler) }, registerHooks = function(handlers){ for (i in 1:length(handlers)){ stage <- names(handlers)[i] h <- handlers[[i]] self$registerHook(stage, h) } } ), private=list( hooks = list( ), runHooks = function(stage, args){ if (missing(args)){ args <- list() } value <- args$value for (h in private$hooks[[stage]]){ ar <- getRelevantArgs(args, plumberExpression=h) value <- do.call(h, ar) #TODO: envir=private$envir? if ("value" %in% names(ar)){ # Special case, retain the returned value from the hook # and pass it in as the value for the next handler. # Ultimately, return value from this function args$value <- value } } # Return the value as passed in or as explcitly modified by one or more hooks. args$value } ) ) #' Plumber Router #' #' Routers are the core request handler in plumber. A router is responsible for #' taking an incoming request, submitting it through the appropriate filters and #' eventually to a corresponding endpoint, if one is found. #' #' See \url{http://www.rplumber.io/docs/programmatic/} for additional #' details on the methods available on this object. #' @param file The file to parse as the plumber router definition #' @param dir The directory containing the `plumber.R` file to parse as the #' plumber router definition. Alternatively, if an `entrypoint.R` file is #' found, it will take precedence and be responsible for returning a runnable #' Plumber router. #' @include globals.R #' @include serializer-json.R #' @include parse-block.R #' @include parse-globals.R #' @export #' @importFrom httpuv runServer #' @import crayon plumber <- R6Class( "plumber", inherit = hookable, public = list( initialize = function(file=NULL, filters=defaultPlumberFilters, envir){ if (!is.null(file)){ if (!file.exists(file)){ stop("File does not exist: ", file) } else { inf <- file.info(file) if (inf$isdir){ stop("Expecting a file but found a directory: '", file, "'.") } } } if (missing(envir)){ private$envir <- new.env(parent=.GlobalEnv) } else { private$envir <- envir } if (is.null(filters)){ filters <- list() } # Add in the initial filters for (fn in names(filters)){ fil <- PlumberFilter$new(fn, filters[[fn]], private$envir, private$serializer, NULL) private$filts <- c(private$filts, fil) } private$errorHandler <- defaultErrorHandler() private$notFoundHandler <- default404Handler if (!is.null(file)){ private$lines <- readLines(file) private$parsed <- parse(file, keep.source=TRUE) source(file, local=private$envir, echo=FALSE, keep.source=TRUE) for (i in 1:length(private$parsed)){ e <- private$parsed[i] srcref <- attr(e, "srcref")[[1]][c(1,3)] activateBlock(srcref, private$lines, e, private$envir, private$addEndpointInternal, private$addFilterInternal, self$mount) } private$globalSettings <- parseGlobals(private$lines) } }, run = function(host='127.0.0.1', port=getOption('plumber.port'), swagger=interactive(), debug=interactive(), swaggerCallback=getOption('plumber.swagger.url', NULL)){ port <- findPort(port) message("Starting server to listen on port ", port) on.exit({ options('plumber.debug' = getOption('plumber.debug')) }) options(plumber.debug = debug) # Set and restore the wd to make it appear that the proc is running local to the file's definition. if (!is.null(private$filename)){ cwd <- getwd() on.exit({ setwd(cwd) }, add = TRUE) setwd(dirname(private$filename)) } if (swagger){ sf <- self$swaggerFile() if (is.na(sf$host)){ accessHost <- ifelse(host == "0.0.0.0", "127.0.0.1", host) accessPath <- paste(accessHost, port, sep=":") sf$host <- accessPath if (!is.null(getOption("plumber.apiHost"))){ sf$host <- getOption("plumber.apiHost") } if (!is.null(getOption("plumber.apiScheme"))){ sf$schemes <- getOption("plumber.apiScheme") } if (!is.null(getOption("plumber.apiPath"))){ sf$basePath <- getOption("plumber.apiPath") } } # Create a function that's hardcoded to return the swaggerfile -- regardless of env. fun <- function(schemes, host, path){ if (!missing(schemes)){ sf$schemes <- I(schemes) } if (!missing(host)){ sf$host <- host } if (!missing(path)){ sf$basePath <- path } sf } self$handle("GET", "/swagger.json", fun, serializer=serializer_unboxed_json()) plumberFileServer <- PlumberStatic$new(system.file("swagger-ui", package = "plumber")) self$mount("/__swagger__", plumberFileServer) swaggerUrl = paste(sf$schemes[1], "://", sf$host, "/__swagger__/", sep="") message("Running the swagger UI at ", swaggerUrl, sep="") if (!is.null(swaggerCallback) && is.function(swaggerCallback)){ swaggerCallback(swaggerUrl) } } on.exit(private$runHooks("exit"), add=TRUE) httpuv::runServer(host, port, self) }, mount = function(path, router){ path <- sub("([^/])$", "\\1/", path) private$mnts[[path]] <- router }, registerHook = function(stage=c("preroute", "postroute", "preserialize", "postserialize", "exit"), handler){ stage <- match.arg(stage) super$registerHook(stage, handler) }, handle = function(methods, path, handler, preempt, serializer, endpoint){ epdef <- !missing(methods) || !missing(path) || !missing(handler) || !missing(serializer) if (!missing(endpoint) && epdef){ stop("You must provide either the components for an endpoint (handler and serializer) OR provide the endpoint yourself. You cannot do both.") } if (epdef){ if (missing(serializer)){ serializer <- private$serializer } endpoint <- PlumberEndpoint$new(methods, path, handler, private$envir, serializer) } private$addEndpointInternal(endpoint, preempt) }, print = function(prefix="", topLevel=TRUE, ...){ endCount <- as.character(sum(unlist(lapply(self$endpoints, length)))) # Reference on box characters: https://en.wikipedia.org/wiki/Box-drawing_character cat(prefix) if (!topLevel){ cat("\u2502 ") # "| " } cat(crayon::silver("# Plumber router with ", endCount, " endpoint", ifelse(endCount == 1, "", "s"),", ", as.character(length(private$filts)), " filter", ifelse(length(private$filts) == 1, "", "s"),", and ", as.character(length(self$mounts)), " sub-router", ifelse(length(self$mounts) == 1, "", "s"),".\n", sep="")) if(topLevel){ cat(prefix, crayon::silver("# Call run() on this object to start the API.\n"), sep="") } # Filters # TODO: scrub internal filters? for (f in private$filts){ cat(prefix, "\u251c\u2500\u2500", crayon::green("[", f$name, "]", sep=""), "\n", sep="") # "+--" } paths <- self$routes printEndpoints <- function(prefix, name, nodes, isLast){ if (is.list(nodes)){ verbs <- paste(sapply(nodes, function(n){ n$verbs }), collapse=", ") } else { verbs <- nodes$verbs } cat(prefix) if (isLast){ cat("\u2514") # "|_" } else { cat("\u251c") # "+" } cat(crayon::blue("\u2500\u2500/", name, " (", verbs, ")\n", sep=""), sep="") # "+--" } printNode <- function(node, name="", prefix="", isRoot=FALSE, isLast = FALSE){ childPref <- paste0(prefix, "\u2502 ") if (isRoot){ childPref <- prefix } if (is.list(node)){ if (is.null(names(node))) { # This is a list of Plumber endpoints all mounted at this location. Collapse printEndpoints(prefix, name, node, isLast) } else{ # It's a list of other stuff. if (!isRoot){ cat(prefix, "\u251c\u2500\u2500/", name, "\n", sep="") # "+--" } for (i in 1:length(node)){ name <- names(node)[i] printNode(node[[i]], name, childPref, isLast = i == length(node)) } } } else if ("plumber" %in% class(node)){ cat(prefix, "\u251c\u2500\u2500/", name, "\n", sep="") # "+--" # It's a router, let it print itself print(node, prefix=childPref, topLevel=FALSE) } else if ("PlumberEndpoint" %in% class(node)){ printEndpoints(prefix, name, node, isLast) } else { cat("??") } } printNode(paths, "", prefix, TRUE) invisible(self) }, serve = function(req, res){ hookEnv <- new.env() private$runHooks("preroute", list(data=hookEnv, req=req, res=res)) val <- self$route(req, res) # Because we're passing in a `value` argument here, `runHooks` will return either the # unmodified `value` argument back, or will allow one or more hooks to modify the value, # in which case the modified value will be returned. Hooks declare that they intend to # modify the value by accepting a parameter named `value`, in which case their returned # value will be used as the updated value. val <- private$runHooks("postroute", list(data=hookEnv, req=req, res=res, value=val)) if ("PlumberResponse" %in% class(val)){ # They returned the response directly, don't serialize. res$toResponse() } else { ser <- res$serializer if (typeof(ser) != "closure") { stop("Serializers must be closures: '", ser, "'") } val <- private$runHooks("preserialize", list(data=hookEnv, req=req, res=res, value=val)) out <- ser(val, req, res, private$errorHandler) out <- private$runHooks("postserialize", list(data=hookEnv, req=req, res=res, value=out)) out } }, route = function(req, res){ getHandle <- function(filt){ handlers <- private$ends[[filt]] if (!is.null(handlers)){ for (h in handlers){ if (h$canServe(req)){ return(h) } } } NULL } # Get args out of the query string, + req/res args <- list() if (!is.null(req$args)){ args <- req$args } args$res <- res args$req <- req req$args <- args path <- req$PATH_INFO oldWarn <- options("warn")[[1]] tryCatch({ # Set to show warnings immediately as they happen. options(warn=1) h <- getHandle("__first__") if (!is.null(h)){ if (!is.null(h$serializer)){ res$serializer <- h$serializer } req$args <- c(h$getPathParams(path), req$args) return(do.call(h$exec, req$args)) } if (length(private$filts) > 0){ # Start running through filters until we find a matching endpoint. for (i in 1:length(private$filts)){ fi <- private$filts[[i]] # Check for endpoints preempting in this filter. h <- getHandle(fi$name) if (!is.null(h)){ if (!is.null(h$serializer)){ res$serializer <- h$serializer } req$args <- c(h$getPathParams(path), req$args) return(do.call(h$exec, req$args)) } # Execute this filter .globals$forwarded <- FALSE fres <- do.call(fi$exec, req$args) if (!.globals$forwarded){ # forward() wasn't called, presumably meaning the request was # handled inside of this filter. if (!is.null(fi$serializer)){ res$serializer <- fi$serializer } return(fres) } } } # If we still haven't found a match, check the un-preempt'd endpoints. h <- getHandle("__no-preempt__") if (!is.null(h)){ if (!is.null(h$serializer)){ res$serializer <- h$serializer } req$args <- c(h$getPathParams(path), req$args) return(do.call(h$exec, req$args)) } # We aren't going to serve this endpoint; see if any mounted routers will for (mountPath in names(private$mnts)){ # TODO: support globbing? if (nchar(path) >= nchar(mountPath) && substr(path, 0, nchar(mountPath)) == mountPath){ # This is a prefix match or exact match. Let this router handle. # First trim the prefix off of the PATH_INFO element req$PATH_INFO <- substr(req$PATH_INFO, nchar(mountPath), nchar(req$PATH_INFO)) return(private$mnts[[mountPath]]$route(req, res)) } } # No endpoint could handle this request. 404 val <- private$notFoundHandler(req=req, res=res) return(val) }, error=function(e){ # Error when routing val <- private$errorHandler(req, res, e) return(val) }, finally= options(warn=oldWarn) ) }, # httpuv interface call = function(req){ # Due to https://github.com/rstudio/httpuv/issues/49, we need to close # the TCP channels via `Connection: close` header. Otherwise we would # reuse the same environment for each request and potentially recycle # old data here. # Set the arguments to an empty list req$args <- list() req$.internal <- new.env() res <- PlumberResponse$new(private$serializer) self$serve(req, res) }, onHeaders = function(req){ NULL }, onWSOpen = function(ws){ warning("WebSockets not supported.") }, setSerializer = function(serializer){ private$serializer <- serializer }, # Set a default serializer set404Handler = function(fun){ private$notFoundHandler <- fun }, setErrorHandler = function(fun){ private$errorHandler <- fun }, filter = function(name, expr, serializer){ filter <- PlumberFilter$new(name, expr, private$envir, serializer) private$addFilterInternal(filter) }, swaggerFile = function(){ #FIXME: test endpoints <- prepareSwaggerEndpoints(self$endpoints) # Extend the previously parsed settings with the endpoints def <- modifyList(private$globalSettings, list(paths=endpoints)) # Lay those over the default globals so we ensure that the required fields # (like API version) are satisfied. modifyList(defaultGlobals, def) }, ### Legacy/Deprecated addEndpoint = function(verbs, path, expr, serializer, processors, preempt=NULL, params=NULL, comments){ warning("addEndpoint has been deprecated in v0.4.0 and will be removed in a coming release. Please use `handle()` instead.") if (!missing(processors) || !missing(params) || !missing(comments)){ stop("The processors, params, and comments parameters are no longer supported.") } self$handle(verbs, path, expr, preempt, serializer) }, addAssets = function(dir, path="/public", options=list()){ warning("addAssets has been deprecated in v0.4.0 and will be removed in a coming release. Please use `mount` and `PlumberStatic$new()` instead.") if (substr(path, 1,1) != "/"){ path <- paste0("/", path) } stat <- PlumberStatic$new(dir, options) self$mount(path, stat) }, addFilter = function(name, expr, serializer, processors){ warning("addFilter has been deprecated in v0.4.0 and will be removed in a coming release. Please use `filter` instead.") if (!missing(processors)){ stop("The processors parameter is no longer supported.") } filter <- PlumberFilter$new(name, expr, private$envir, serializer) private$addFilterInternal(filter) }, addGlobalProcessor = function(proc){ warning("addGlobalProcessor has been deprecated in v0.4.0 and will be removed in a coming release. Please use `registerHook`(s) instead.") self$registerHooks(proc) } ), active = list( endpoints = function(){ # read-only private$ends }, filters = function(){ # read-only private$filts }, mounts = function(){ # read-only private$mnts }, environment = function() { #read-only private$envir }, routes = function(){ paths <- list() addPath <- function(node, children, endpoint){ if (length(children) == 0){ if (is.null(node)){ return(endpoint) } else { # Concat to existing. return(c(node, endpoint)) } } if (is.null(node)){ node <- list() } node[[children[1]]] <- addPath(node[[children[1]]], children[-1], endpoint) node } lapply(self$endpoints, function(ends){ lapply(ends, function(e){ # Trim leading slash path <- sub("^/", "", e$path) levels <- strsplit(path, "/", fixed=TRUE)[[1]] paths <<- addPath(paths, levels, e) }) }) # Sub-routers if (length(self$mounts) > 0){ for(i in 1:length(self$mounts)){ # Trim leading slash path <- sub("^/", "", names(self$mounts)[i]) levels <- strsplit(path, "/", fixed=TRUE)[[1]] m <- self$mounts[[i]] paths <- addPath(paths, levels, m) } } # TODO: Sort lexicographically paths } ), private = list( serializer = serializer_json(), # The default serializer for the router ends = list(), # List of endpoints indexed by their pre-empted filter. filts = NULL, # Array of filters mnts = list(), envir = NULL, # The environment in which all API execution will be conducted lines = NULL, # The lines constituting the API parsed = NULL, # The parsed representation of the API globalSettings = list(info=list()), # Global settings for this API. Primarily used for Swagger docs. errorHandler = NULL, notFoundHandler = NULL, addFilterInternal = function(filter){ # Create a new filter and add it to the router private$filts <- c(private$filts, filter) invisible(self) }, addEndpointInternal = function(ep, preempt){ noPreempt <- missing(preempt) || is.null(preempt) filterNames <- "__first__" for (f in private$filts){ filterNames <- c(filterNames, f$name) } if (!noPreempt && ! preempt %in% filterNames){ if (!is.null(ep$lines)){ stopOnLine(ep$lines[1], private$fileLines[ep$lines[1]], paste0("The given @preempt filter does not exist in this plumber router: '", preempt, "'")) } else { stop(paste0("The given preempt filter does not exist in this plumber router: '", preempt, "'")) } } if (noPreempt){ preempt <- "__no-preempt__" } private$ends[[preempt]] <- c(private$ends[[preempt]], ep) } ) ) plumber/R/new-rstudio-project.R0000644000176200001440000000157513304040260016170 0ustar liggesusers# This function is invoked when creating a new Plumber API project in the # RStudio IDE. The function will be called when the user invokes the # New Project wizard using the project template defined in the file at: # # inst/rstudio/templates/project/new-rstudio-project.dcf # The new project template mechanism is documented at: # https://rstudio.github.io/rstudio-extensions/rstudio_project_templates.html newRStudioProject <- function(path, ...) { # ensure path exists dir.create(path, recursive = TRUE, showWarnings = FALSE) # copy 'resources' folder to path resources <- system.file("rstudio", "templates", "project", "resources", package = "plumber", mustWork = TRUE) files <- list.files(resources, recursive = TRUE, include.dirs = FALSE) source <- file.path(resources, files) target <- file.path(path, files) file.copy(source, target) } plumber/R/parse-block.R0000644000176200001440000002040013304040260014432 0ustar liggesusers # TODO: delete once we require R 3.3.0 trimws <- function(string){ string <- gsub("^\\s+", "", string) gsub("\\s+$", "", string) } stopOnLine <- function(lineNum, line, msg){ stop("Error on line #", lineNum, ": '", line, "' - ", msg) } #' @param lineNum The line number just above the function we're documenting #' @param file A character vector representing all the lines in the file #' @noRd parseBlock <- function(lineNum, file){ paths <- NULL preempt <- NULL filter <- NULL image <- NULL imageAttr <- NULL serializer <- NULL assets <- NULL params <- NULL comments <- "" responses <- NULL tags <- NULL while (lineNum > 0 && (stri_detect_regex(file[lineNum], pattern="^#['\\*]") || stri_trim_both(file[lineNum]) == "")){ line <- file[lineNum] epMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(get|put|post|use|delete|head|options|patch)(\\s+(.*)$)?") if (!is.na(epMat[1,2])){ p <- stri_trim_both(epMat[1,4]) if (is.na(p) || p == ""){ stopOnLine(lineNum, line, "No path specified.") } if (is.null(paths)){ paths <- list() } paths[[length(paths)+1]] <- list(verb = enumerateVerbs(epMat[1,2]), path = p) } filterMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@filter(\\s+(.*)$)?") if (!is.na(filterMat[1,1])){ f <- stri_trim_both(filterMat[1,3]) if (is.na(f) || f == ""){ stopOnLine(lineNum, line, "No @filter name specified.") } if (!is.null(filter)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple @filters specified for one function.") } filter <- f } preemptMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@preempt(\\s+(.*)\\s*$)?") if (!is.na(preemptMat[1,1])){ p <- stri_trim_both(preemptMat[1,3]) if (is.na(p) || p == ""){ stopOnLine(lineNum, line, "No @preempt specified") } if (!is.null(preempt)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple @preempts specified for one function.") } preempt <- p } assetsMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@assets(\\s+(\\S*)(\\s+(\\S+))?\\s*)?$") if (!is.na(assetsMat[1,1])){ dir <- stri_trim_both(assetsMat[1,3]) if (is.na(dir) || dir == ""){ stopOnLine(lineNum, line, "No directory specified for @assets") } prefixPath <- stri_trim_both(assetsMat[1,5]) if (is.na(prefixPath) || prefixPath == ""){ prefixPath <- "/public" } if (!is.null(assets)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple @assets specified for one entity.") } assets <- list(dir=dir, path=prefixPath) } serMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@serializer(\\s+([^\\s]+)\\s*(.*)\\s*$)?") if (!is.na(serMat[1,1])){ s <- stri_trim_both(serMat[1,3]) if (is.na(s) || s == ""){ stopOnLine(lineNum, line, "No @serializer specified") } if (!is.null(serializer)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple @serializers specified for one function.") } if (!s %in% names(.globals$serializers)){ stop("No such @serializer registered: ", s) } ser <- .globals$serializers[[s]] if (!is.na(serMat[1, 4]) && serMat[1,4] != ""){ # We have an arg to pass in to the serializer argList <- eval(parse(text=serMat[1,4])) serializer <- do.call(ser, argList) } else { serializer <- ser() } } shortSerMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(json|html)") if (!is.na(shortSerMat[1,2])){ s <- stri_trim_both(shortSerMat[1,2]) if (!is.null(serializer)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple @serializers specified for one function (shorthand serializers like @json count, too).") } if (!is.na(s) && !s %in% names(.globals$serializers)){ stop("No such @serializer registered: ", s) } # TODO: support arguments to short serializers once they require them. serializer <- .globals$serializers[[s]]() } imageMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@(jpeg|png)([\\s\\(].*)?\\s*$") if (!is.na(imageMat[1,1])){ if (!is.null(image)){ # Must have already assigned. stopOnLine(lineNum, line, "Multiple image annotations on one function.") } image <- imageMat[1,2] imageAttr <- trimws(imageMat[1,3]) if (is.na(imageAttr)){ imageAttr <- "" } if(!identical(imageAttr, "") && !grepl("^\\(.*\\)$", imageAttr, perl=TRUE)){ stopOnLine(lineNum, line, "Supplemental arguments to the image serializer must be surrounded by parentheses, as in `#' @png (width=200)`") } } responseMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@response\\s+(\\w+)\\s+(\\S.+)\\s*$") if (!is.na(responseMat[1,1])){ resp <- list() resp[[responseMat[1,2]]] <- list(description=responseMat[1,3]) responses <- c(responses, resp) } paramMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@param(\\s+([^\\s]+)(\\s+(.*))?\\s*$)?") if (!is.na(paramMat[1,2])){ p <- stri_trim_both(paramMat[1,3]) if (is.na(p) || p == ""){ stopOnLine(lineNum, line, "No parameter specified.") } name <- paramMat[1,3] type <- NA nameType <- stringi::stri_match(name, regex="^([^\\s]+):(\\w+)(\\*?)$") if (!is.na(nameType[1,1])){ name <- nameType[1,2] type <- plumberToSwaggerType(nameType[1,3]) #stopOnLine(lineNum, line, "No parameter type specified") } reqd <- FALSE if (!is.na(nameType[1,4])){ reqd <- nameType[1,4] == "*" } params[[name]] <- list(desc=paramMat[1,5], type=type, required=reqd) } tagMat <- stringi::stri_match(line, regex="^#['\\*]\\s*@tag\\s+(\\S.+)\\s*") if (!is.na(tagMat[1,1])){ t <- stri_trim_both(tagMat[1,2]) if (is.na(t) || t == ""){ stopOnLine(lineNum, line, "No tag specified.") } if (t %in% tags){ stopOnLine(lineNum, line, "Duplicate tag specified.") } tags <- c(tags, t) } commentMat <- stringi::stri_match(line, regex="^#['\\*]\\s*([^@\\s].*$)") if (!is.na(commentMat[1,2])){ comments <- paste(comments, commentMat[1,2]) } lineNum <- lineNum - 1 } list( paths = paths, preempt = preempt, filter = filter, image = image, imageAttr = imageAttr, serializer = serializer, assets = assets, params = params, comments = comments, responses = responses, tags = tags ) } #' Activate a "block" of code found in a plumber API file. #' @include images.R #' @noRd activateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, mount) { lineNum <- srcref[1] - 1 block <- parseBlock(lineNum, file) if (sum(!is.null(block$filter), !is.null(block$paths), !is.null(block$assets)) > 1){ stopOnLine(lineNum, file[lineNum], "A single function can only be a filter, an API endpoint, or an asset (@filter AND @get, @post, @assets, etc.)") } if (!is.null(block$paths)){ lapply(block$paths, function(p){ ep <- PlumberEndpoint$new(p$verb, p$path, expr, envir, block$serializer, srcref, block$params, block$comments, block$responses, block$tags) if (!is.null(block$image)){ # Arguments to pass in to the image serializer imageArgs <- NULL if (!identical(block$imageAttr, "")){ call <- paste("list", block$imageAttr) imageArgs <- eval(parse(text=call)) } if (block$image == "png"){ ep$registerHooks(render_png(imageArgs)) } else if (block$image == "jpeg"){ ep$registerHooks(render_jpeg(imageArgs)) } else { stop("Image format not found: ", block$image) } } addEndpoint(ep, block$preempt) }) } else if (!is.null(block$filter)){ filter <- PlumberFilter$new(block$filter, expr, envir, block$serializer, srcref) addFilter(filter) } else if (!is.null(block$assets)){ path <- block$assets$path # Leading slash if (substr(path, 1,1) != "/"){ path <- paste0("/", path) } stat <- PlumberStatic$new(block$assets$dir, expr) mount(path, stat) } } plumber/R/swagger.R0000644000176200001440000000610213304040260013672 0ustar liggesusers#' Parse the given plumber type and return the typecast value #' @noRd plumberToSwaggerType <- function(type){ if (type == "bool" || type == "logical"){ return("boolean") } else if (type == "double" || type == "numeric"){ return("number") } else if (type == "int"){ return("integer") } else if (type == "character"){ return("string") } else { stop("Unrecognized type: ", type) } } #' Convert the endpoints as they exist on the router to a list which can #' be converted into a swagger definition for these endpoints #' @noRd prepareSwaggerEndpoints <- function(routerEndpoints){ endpoints <- list() for (fil in routerEndpoints){ for (e in fil){ # TODO: we are sensitive to trailing slashes. Should we be? cleanedPath <- gsub("<([^:>]+)(:[^>]+)?>", "{\\1}", e$path) if (is.null(endpoints[[cleanedPath]])){ endpoints[[cleanedPath]] <- list() } # Get the params from the path pathParams <- e$getTypedParams() for (verb in e$verbs){ params <- extractSwaggerParams(e$params, pathParams) # If we haven't already documented a path param, we should add it here. # FIXME: warning("Undocumented path parameters: ", paste0()) resps <- extractResponses(e$responses) endptSwag <- list(summary=e$comments, responses=resps, parameters=params, tags=e$tags) endpoints[[cleanedPath]][[tolower(verb)]] <- endptSwag } } } endpoints } defaultResp <- list("default"=list(description="Default response.")) extractResponses <- function(resps){ if (is.null(resps) || is.na(resps)){ resps <- defaultResp } else if (!("default" %in% names(resps))){ resps <- c(resps, defaultResp) } resps } #' Extract the swagger-friendly parameter definitions from the endpoint #' paramters. #' @noRd extractSwaggerParams <- function(endpointParams, pathParams){ params <- data.frame(name=character(0), description=character(0), `in`=character(0), required=logical(0), type=character(0), check.names = FALSE, stringsAsFactors = FALSE) for (p in names(endpointParams)){ location <- "query" if (p %in% pathParams$name){ location <- "path" } type <- endpointParams[[p]]$type if (is.null(type) || is.na(type)){ if (location == "path") { type <- plumberToSwaggerType(pathParams[pathParams$name == p,"type"]) } else { type <- "string" # Default to string } } parDocs <- data.frame(name = p, description = endpointParams[[p]]$desc, `in`=location, required=endpointParams[[p]]$required, type=type, check.names = FALSE, stringsAsFactors = FALSE) if (location == "path"){ parDocs$required <- TRUE } params <- rbind(params, parDocs) } params } plumber/R/shared-secret-filter.R0000644000176200001440000000051713304040260016253 0ustar liggesusers#' @noRd sharedSecretFilter <- function(req, res){ secret <- getOption("plumber.sharedSecret", NULL) if (!is.null(secret)){ supplied <- req$HTTP_PLUMBER_SHARED_SECRET if (!identical(supplied, secret)){ res$status <- 400 stop("The provided shared secret did not match expected secret.") } } forward() } plumber/R/response.R0000644000176200001440000000471213305305241014102 0ustar liggesusersPlumberResponse <- R6Class( "PlumberResponse", public = list( initialize = function(serializer=serializer_json()){ self$serializer <- serializer }, status = 200L, body = NULL, headers = list(), serializer = NULL, setHeader = function(name, value){ he <- list() he[[name]] <- value self$headers <- c(self$headers, he) }, toResponse = function(){ h <- self$headers # httpuv doesn't like empty headers lists, and this is a useful field anyway... h$Date <- format(Sys.time(), "%a, %d %b %Y %X %Z", tz="GMT") # Due to https://github.com/rstudio/httpuv/issues/49, we need each # request to be on a separate TCP stream h$Connection = "close" body <- self$body if (is.null(body)){ body <- "" } charset <- getCharacterSet(h$HTTP_CONTENT_TYPE) if (is.character(body)) { Encoding(body) <- charset } list( status = self$status, headers = h, body = body ) }, # TODO: support multiple setCookies per response setCookie = function(name, value, path, expiration=FALSE, http=FALSE, secure=FALSE){ self$setHeader("Set-Cookie", cookieToStr(name, value, path, expiration, http, secure)) } ) ) #' @importFrom utils URLencode #' @noRd cookieToStr <- function(name, value, path, expiration=FALSE, http=FALSE, secure=FALSE){ val <- URLencode(as.character(value)) str <- paste0(name, "=", val, "; ") if (!missing(path)){ str <- paste0(str, "Path=", path, "; ") } if (!missing(http) && http){ str <- paste0(str, "HttpOnly; ") } if (!missing(secure) && secure){ str <- paste0(str, "Secure; ") } if (!missing(expiration)){ if (is.numeric(expiration)){ # Number of seconds in the future now <- Sys.time() expy <- now + expiration expyStr <- format(expy, format="%a, %e %b %Y %T", tz="GMT", usetz=TRUE) str <- paste0(str, "Expires= ", expyStr, "; ") str <- paste0(str, "Max-Age= ", expiration, "; ") } else if (inherits(expiration, "POSIXt")){ seconds <- difftime(expiration, Sys.time(), units="secs") # TODO: DRY expyStr <- format(expiration, format="%a, %e %b %Y %T", tz="GMT", usetz=TRUE) str <- paste0(str, "Expires= ", expyStr, "; ") str <- paste0(str, "Max-Age= ", as.integer(seconds), "; ") } # interpret all other values as session cookies. } # Trim last '; ' substr(str, 0, nchar(str)-2) } plumber/R/includes.R0000644000176200001440000000335613304040260014051 0ustar liggesusersrequireRmd <- function(fun_name){ if (!requireNamespace("rmarkdown", quietly = TRUE)) { stop("The rmarkdown package is not available but is required in order to use ", fun_name, call. = FALSE) } } #' Send File Contents as Response #' #' Returns the file at the given path as the response. #' #' \code{include_html} will merely return the file with the proper #' \code{content_type} for HTML. \code{include_md} and \code{include_rmd} will #' process the given markdown file through \code{rmarkdown::render} and return #' the resultant HTML as a response. #' #' @param file The path to the file to return #' @param res The response object into which we'll write #' @param content_type If provided, the given value will be sent as the #' \code{Content-type} header in the response. #' @export include_file <- function(file, res, content_type){ # TODO stream this directly to the request w/o loading in memory # TODO set content type automatically lines <- paste(readLines(file), collapse="\n") res$serializer <- "null" res$body <- c(res$body, lines) if (!missing(content_type)){ res$setHeader("Content-type", content_type) } res } #' @rdname include_file #' @export include_html <- function(file, res){ include_file(file, res, content_type="text/html; charset=utf-8") } #' @rdname include_file #' @param format Passed as the \code{output_format} to \code{rmarkdown::render} #' @export include_md <- function(file, res, format = NULL){ requireRmd("include_md") f <- rmarkdown::render(file, format, quiet=TRUE) include_html(f, res) } #' @rdname include_file #' @export include_rmd <- function(file, res, format = NULL){ requireRmd("include_rmd") f <- rmarkdown::render(file, format, quiet=TRUE) include_html(f, res) } plumber/README.md0000644000176200001440000000700713304040260013173 0ustar liggesusers# plumber [![Build Status](https://travis-ci.org/trestletech/plumber.svg?branch=master)](https://travis-ci.org/trestletech/plumber) [![](https://www.r-pkg.org/badges/version/plumber)](https://www.r-pkg.org/pkg/plumber) [![CRAN RStudio mirror downloads](https://cranlogs.r-pkg.org/badges/plumber?color=brightgreen)](https://www.r-pkg.org/pkg/plumber) [![codecov](https://codecov.io/gh/trestletech/plumber/branch/master/graph/badge.svg)](https://codecov.io/gh/trestletech/plumber) Plumber allows you to create a web API by merely decorating your existing R source code with special comments. Take a look at an example. ```r # plumber.R #* Echo back the input #* @param msg The message to echo #* @get /echo function(msg=""){ list(msg = paste0("The message is: '", msg, "'")) } #* Plot a histogram #* @png #* @get /plot function(){ rand <- rnorm(100) hist(rand) } #* Return the sum of two numbers #* @param a The first number to add #* @param b The second number to add #* @post /sum function(a, b){ as.numeric(a) + as.numeric(b) } ``` These comments allow plumber to make your R functions available as API endpoints. You can use either `#*` as the prefix or `#'`, but we recommend the former since `#'` will collide with Roxygen. ```r > library(plumber) > r <- plumb("plumber.R") # Where 'plumber.R' is the location of the file shown above > r$run(port=8000) ``` You can visit this URL using a browser or a terminal to run your R function and get the results. For instance [http://localhost:8000/plot](http://localhost:8000/plot) will show you a histogram, and [http://localhost:8000/echo?msg=hello](http://localhost:8000/echo?msg=hello) will echo back the 'hello' message you provided. Here we're using `curl` via a Mac/Linux terminal. ``` $ curl "http://localhost:8000/echo" {"msg":["The message is: ''"]} $ curl "http://localhost:8000/echo?msg=hello" {"msg":["The message is: 'hello'"]} ``` As you might have guessed, the request's query string parameters are forwarded to the R function as arguments (as character strings). ``` $ curl --data "a=4&b=3" "http://localhost:8000/sum" [7] ``` You can also send your data as JSON: ``` $ curl --data '{"a":4, "b":5}' http://localhost:8000/sum [9] ``` ## Installation You can install the latest stable version from CRAN using the following command: ```r install.packages("plumber") ``` If you want to try out the latest development version, you can install it from GitHub. The easiest way to do that is by using `devtools`. ```r library(devtools) install_github("trestletech/plumber") library(plumber) ``` ## Hosting If you're just getting started with hosting cloud servers, the DigitalOcean integration included in plumber will be the best way to get started. You'll be able to get a server hosting your custom API in just two R commands. Full documentation is available at https://www.rplumber.io/docs/digitalocean/. A couple of other approaches to hosting plumber are also made available: - PM2 - https://www.rplumber.io/docs/hosting/ - Docker - https://www.rplumber.io/docs/docker/ ## Related Projects - [OpenCPU](https://www.opencpu.org/) - A server designed for hosting R APIs with an eye towards scientific research. - [jug](http://bart6114.github.io/jug/index.html) - *(development discontinued)* an R package similar to Plumber but uses a more programmatic approach to constructing the API. ## Provenance plumber was originally released as the `rapier` package and has since been renamed (7/13/2015). plumber/MD50000644000176200001440000002326413305412327012237 0ustar liggesusersfd015d810a1032a39cd3bd214844288e *DESCRIPTION 9bff9c7f87f60a5cb676ac4aed48e64f *LICENSE df3b058a80ca2a9354fc1cec2f713305 *NAMESPACE 30d41602e18137eef5dc08d1e8d13513 *NEWS.md c59cfc32f756146fc346ca98c2346045 *R/content-types.R c167c3cc9edd13cc74e337487c7f46d7 *R/cookie-parser.R 01535d5503964ee1215bcf3b22fec5fc *R/default-handlers.R 263298b3c86e4f2d6b39ac9a825dab34 *R/digital-ocean.R 855dfab72db924541e09708d850db2f8 *R/find-port.R 01948eee6800f095015d934bd32f337f *R/globals.R 36ba1954da502c8c5a943f6155b95cc2 *R/images.R 549f8e0f07118cb0cd3e80590a8a75ca *R/includes.R a74d9c0f8c7f19879a3bdb67d5f43009 *R/new-rstudio-project.R 8889a5e26de1aa3c15f0cd01e6f7b54c *R/parse-block.R 671e4f5471971d0f6ee5328a90054e4f *R/parse-globals.R d1ebb11bde3715c1dabbe8bbcd2bf122 *R/paths.R ce0d759fe3e4f52a18e8249b3accc613 *R/plumber-static.R cb3e3e6f6eaab15a6ee241635f303516 *R/plumber-step.R cc4bd1016ff043d7a79f99aef5aae471 *R/plumber.R cfd64dc48180edbba851b272eca785c1 *R/post-body.R 0244573ceb93e10cfc405b1bc18bfe82 *R/query-string.R ea4fea20534c0e41f75b3127b9fea1e9 *R/response.R df135bc2cd0ebb49046e14cd5169710e *R/serializer-content-type.R 1eeeb02f5b078b98289607032c8b041c *R/serializer-html.R ce5c0c26273c51e4f0f7abd0a5ef8e6e *R/serializer-htmlwidget.R e3d21c005bc0d660645c7d7cf0e56a5b *R/serializer-json.R 602e1f8decb89976da4a41c9761ea710 *R/serializer-xml.R 301ddd4d35d103ce451c5714aec1c7d5 *R/serializer.R dc0664c576655140c51d79c5c74ba212 *R/session-cookie.R 42d53b952fe5a4da901a907d3c1f76f0 *R/shared-secret-filter.R b705507ed9234b8e933c51a90bdabaa9 *R/swagger.R 64520eec4c51f70b26922b38e6e99226 *README.md 31d12c9a0db993c2b0c03725e5f9ccab *inst/examples/01-append/plumber.R 847acb9f180dbddf3c67b7f51d2de6c7 *inst/examples/02-filters/plumber.R 6400525052c737f2c408d6f2231d8685 *inst/examples/03-github/plumber.R dff1e10cb21d139ed3b9946e87e40b4b *inst/examples/04-mean-sum/plumber.R d21016e6a1667ec1fff6a6802a5c06b8 *inst/examples/05-static/README.md 6a572b3edc3dec2fb63a1b1e3255b585 *inst/examples/05-static/files/a.html beb5fd527782be00bdefa5505a966b4c *inst/examples/05-static/files/b.txt 0cc834b2d5d0efd35aac63d0b7293a0d *inst/examples/05-static/plumber.R a1a6fe68510ad8a33f45e08b36a55c89 *inst/examples/06-sessions/plumber.R c1a124875091fecb71cd1b0ff64cb129 *inst/examples/06-sessions/static/iframe-secure.html 826a7bea195aea4be2a12b68356293aa *inst/examples/06-sessions/static/iframe.html 4267ca2ad4775939b5685313e1eedd8c *inst/examples/06-sessions/static/js-cookie.js 3b1da9944a810a17da5ab2e7f38af6cd *inst/examples/07-mailgun/plumber.R 1619512b07ad2f307d31959d1752c592 *inst/examples/08-identity/plumber.R 23dbbb314f9011b6eddbad7448f7f798 *inst/examples/09-content-type/plumber.R 05dbb50b7ad251a5a1127014887b9b00 *inst/examples/10-welcome/plumber.R 6a7a8fec57e159e573396e9cf59ecece *inst/examples/11-car-inventory/inventory.csv 6007bbd25cd6cb0eacf446102140b753 *inst/examples/11-car-inventory/plumber.R 0f46e0c14a80d2222814b0165e927ea4 *inst/examples/12-entrypoint/entrypoint.R 56ee6d1773da7018cc895056a32b08e2 *inst/examples/12-entrypoint/myplumberapi.R 1779aa39ecba0e3b19cac4a229bcf916 *inst/hosted-new.R 908c48fd48d0034e0e85c74964d51615 *inst/hosted/analogsea-provision.R 205d4908fe9fe0e8fb1b9f6c2e05bb8d *inst/hosted/docker-compose.yml 4ad2a105549c584597625139f1095851 *inst/hosted/nginx.conf 9a7bc7a533f3abffef2d7b7afa3b111b *inst/rstudio/templates/project/new-rstudio-project.dcf dd3ff7ff147426f41a16806e9ab45f31 *inst/rstudio/templates/project/plumber.png fd63d6b3d8ce371de8ed3f526c93ec3e *inst/rstudio/templates/project/resources/plumber.R c3debbc908d63204353abe5190cbc747 *inst/server/forward.conf ad9ccbf3590337dae4e4c6e937160a4b *inst/server/nginx-ssl.conf 4f9c61b7e2882229c2df28b5b332a664 *inst/server/nginx.conf c773930eed7467ab68e79733f8cad43a *inst/server/plumber-api.conf a8cb39a3e0fa24d530be7facba09b551 *inst/server/plumber.service c864c5ea721758bf5714b78c5d27ee1e *inst/swagger-ui/index.html 544ebc67470dde56569bab10c968cc60 *man/PlumberEndpoint.Rd 6f17a3e178d46f5a9e06ff010ce97b06 *man/PlumberStatic.Rd feefa352d7375cb84d6c7d4a4e7ea1f4 *man/addSerializer.Rd 45b551e4c1451b90cbf41f8d6a02b5ad *man/do_configure_https.Rd a5245aa5e8385828d14fa7024a183f7e *man/do_deploy_api.Rd d5bf024a42bca43bfcbde7a90fe8ccf2 *man/do_forward.Rd 832a7c76ebe0053ed4f91fa2668383d2 *man/do_provision.Rd 883f642f4b99df83829cefb7b24d1b06 *man/do_remove_api.Rd 2b61f3256c90cab245f86c3bebca97c2 *man/do_remove_forward.Rd 14f6f3a7f35a331eaf28bccde4f0fb3e *man/forward.Rd 7a0aa37e9f070c75357e92c11e12070f *man/include_file.Rd e8caa39a2028cc0ecc6ef2e0968f952a *man/plumber.Rd 8aeaca08f66b0bfe48f48568f2f7bc10 *man/serializers.Rd 45212a148e314a1a1fa0472d2f93a52e *man/sessionCookie.Rd 2c7efdfb397364f764bfcfad5c473422 *tests/testthat.R c2449cd70eb4e36a971107d4182d9026 *tests/testthat/files/content-type.R 3deb15e4d2e9996278ede15704dd92df *tests/testthat/files/endpoints-empty.R 3f97bb72da2bc6105e3c2907e67f8e1a *tests/testthat/files/endpoints-old.R 4fe0233fda93a89e004b5a5d773e7504 *tests/testthat/files/endpoints.R 33999aed57eac2ee4465c2c4e3af3f42 *tests/testthat/files/entrypoint-bad/entrypoint.R a4bd29ec3320282aaf1ffa54992c6e17 *tests/testthat/files/entrypoint-bad/plumber.R 658c071824af08cb8da196b9188d2c3f *tests/testthat/files/entrypoint/entrypoint.R a4bd29ec3320282aaf1ffa54992c6e17 *tests/testthat/files/entrypoint/plumber.R 6bb465fa2af10ec32e06f4d3108ff738 *tests/testthat/files/filter-empty.R db3dd8c3451bc36786f55a4329e1c512 *tests/testthat/files/filter-inject.R c6bbed435d27adf361c979db4a140a65 *tests/testthat/files/filter-redundant.R 82b655be79bc4eef0dc7c157ac9e9a5e *tests/testthat/files/filterasset.R fbcc20a147a4513a56a4ae119118d14b *tests/testthat/files/filterpath.R 8c64e41360c94b5ad97b6ecd8a0ac3d8 *tests/testthat/files/filters.R b8cef7670d9383bddc3880d897a83858 *tests/testthat/files/html.R 1973742c4829c0274037cf43c053f22c *tests/testthat/files/image.R a3bc7f49410e6998c41360b7250c8295 *tests/testthat/files/in-env.R 384a70b4289cb80ed0be23d1fdc139eb *tests/testthat/files/include/test-html.html c677aab4146a4ef9d6ba97c751598532 *tests/testthat/files/include/test.Rmd af304918168e858d906b0ea8a80019c4 *tests/testthat/files/include/test.md 9ba80b8c84a0171e8e7f58ffc66e7566 *tests/testthat/files/include/test.txt 7e31f5c34490dec468295bed71420e25 *tests/testthat/files/includes.R 5eb9f5f14d78bb3a911c28ed8da6153b *tests/testthat/files/integration.R 6107849a75a8a2753de58f2abe597903 *tests/testthat/files/path-params.R 3948cebb1c690eef34f69eb6e853edb2 *tests/testthat/files/plumber.R d88052f69349c622779eed25db141b01 *tests/testthat/files/preempt-empty.R e9b912f717dd5c19e65a2e44294b8f25 *tests/testthat/files/preempt-nonexistent.R c3851f7b6938cebf7042f9a6c7e24084 *tests/testthat/files/preempt-redundant.R 5e571587566619b78f54601680b28f92 *tests/testthat/files/preempt.R dff1e10cb21d139ed3b9946e87e40b4b *tests/testthat/files/readme.R 7377aad7b8e9ac3ea0e2903ae4c034c5 *tests/testthat/files/router.R ab40c301d6b626322590dcc317799f65 *tests/testthat/files/serializer-empty.R 9e38ba73dd25dbe793f7b9b955697e1a *tests/testthat/files/serializer-nonexistent.R bf8dd7b808b0bd0caa1ea3b299b482c1 *tests/testthat/files/serializer-redundant.R caabdfabb199c7ad87883eb33d32bdde *tests/testthat/files/serializer.R 86daea58c2e7c5b50fa324e0efc80e4d *tests/testthat/files/static-nodir.R 4e6f127b7b5904c4bf1027df3193dcca *tests/testthat/files/static.R 84883d83e2136cef97cf770bc22b1121 *tests/testthat/files/static/index.html 52035655f64d70dc3d0c65d99aa697e7 *tests/testthat/files/static/test.txt 74a6b95f944bbaf38f0d9612bac61a71 *tests/testthat/files/static/test.txt.zip a70051ec220922677b021209d3f4a4de *tests/testthat/files/terminal-filter.R e056714f760b266733d2a7641ddaad4a *tests/testthat/files/verbs.R 3754d292ce675bdd2d9db77c197271a2 *tests/testthat/files/warn.R 9322e4e9c75a58e56c059321ec7e2a35 *tests/testthat/helper-compare-serializer.R 081516e316f0130ed0f9637952b6f3b0 *tests/testthat/helper-mock-request.R 9c5acc23340ccf9afa2ae3121847b61a *tests/testthat/test-content-type.R 5d99dad321adaba02ec450223984b15f *tests/testthat/test-cookies.R 89fd919061a8e8d482f5998d0f915cd0 *tests/testthat/test-default-handlers.R 6ed7235d12ce8a3d0238faf22112c65e *tests/testthat/test-deprecated.R b5c636ca419c4e2e8ba593d4923ef661 *tests/testthat/test-endpoint.R c853f1dab022def8a8a46fea134faef0 *tests/testthat/test-enumerate.R 52aeeb14cfa96fc094689908dd924fea *tests/testthat/test-filters.R 6b5c396c63815f17abacbdd7b4fd0b6a *tests/testthat/test-find-port.R 4dc791043338ad7d612d5f64254bc8f2 *tests/testthat/test-globals.R dba785d9594ef85d88d9db8a3f3fffd8 *tests/testthat/test-hookable.R cd6cf80ac7d73bf13efa96e6ae2be3d3 *tests/testthat/test-image.R bf3458963b0f4c474302e11e8122e22e *tests/testthat/test-include.R 13729e6ea8e37e9e03536d2c5416371a *tests/testthat/test-injection.R bb32477060156935003db2e1749e6857 *tests/testthat/test-parse-block.R 2195f3c9c627521e3e5baefc7f5905e2 *tests/testthat/test-path-subst.R 250278140e707afa7ee88bae8308054d *tests/testthat/test-plumber.R 00afe67109c039c70eeeb33542f1cd65 *tests/testthat/test-postbody.R 8d0fdb1f064cfb0eb152c30b303ee172 *tests/testthat/test-preempt.R 234b999df91a4d60219def934118b696 *tests/testthat/test-querystring.R 509e4071c191a19ebbf04cc9da4d1c6c *tests/testthat/test-response.R dc3cfd999ad5a21e9514d60da29eb459 *tests/testthat/test-routing.R 7c445e3f4219ad78674bbb7319e1d517 *tests/testthat/test-serializer-html.R ab7fe195d7bd2cd8d7e4609834a592aa *tests/testthat/test-serializer-htmlwidgets.R 97631d56f8bfcd904579c048ffc3c5f7 *tests/testthat/test-serializer-json.R 49a82cc057bf5d3d427ea10b23c6647c *tests/testthat/test-serializer.R 10c6a49aa80f98740a3be8af4c45c76d *tests/testthat/test-sessions.R 4d66ad8c27c3cbd1edfd493eed86e3f9 *tests/testthat/test-shared-secret.R 327e2be0491f91b7539710a3289e0085 *tests/testthat/test-static.R 08be33bd6cd151fb2988741beea69254 *tests/testthat/test-swagger.R fac9f6147551a1ec2b961325fd8af0f5 *tests/testthat/test-warnings.R plumber/DESCRIPTION0000644000176200001440000000372613305412327013436 0ustar liggesusersEncoding: UTF-8 Package: plumber Type: Package Title: An API Generator for R Version: 0.4.6 Authors@R: c( person(family="Trestle Technology, LLC", role="aut", email="cran@trestletech.com"), person("Jeff", "Allen", role="cre", email="cran@trestletech.com"), person("Frans", "van Dunné", role="ctb", email="frans@ixpantia.com"), person("Sebastiaan", "Vandewoude", role="ctb", email="sebastiaanvandewoude@gmail.com"), person(family="SmartBear Software", role=c("ctb", "cph"), comment="swagger-ui")) License: MIT + file LICENSE BugReports: https://github.com/trestletech/plumber/issues URL: https://www.rplumber.io (site) https://github.com/trestletech/plumber (dev) Description: Gives the ability to automatically generate and serve an HTTP API from R functions using the annotations in the R documentation around your functions. Depends: R (>= 3.0.0) Imports: R6 (>= 2.0.0), stringi (>= 0.3.0), jsonlite (>= 0.9.16), httpuv (>= 1.2.3), crayon LazyData: TRUE ByteCompile: TRUE Suggests: testthat (>= 0.11.0), XML, rmarkdown, PKI, base64enc, htmlwidgets, visNetwork, analogsea Collate: 'content-types.R' 'cookie-parser.R' 'parse-globals.R' 'images.R' 'parse-block.R' 'globals.R' 'serializer-json.R' 'shared-secret-filter.R' 'post-body.R' 'query-string.R' 'plumber.R' 'default-handlers.R' 'digital-ocean.R' 'find-port.R' 'includes.R' 'new-rstudio-project.R' 'paths.R' 'plumber-static.R' 'plumber-step.R' 'response.R' 'serializer-content-type.R' 'serializer-html.R' 'serializer-htmlwidget.R' 'serializer-xml.R' 'serializer.R' 'session-cookie.R' 'swagger.R' RoxygenNote: 6.0.1 NeedsCompilation: no Packaged: 2018-06-04 22:23:10 UTC; barret Author: Trestle Technology, LLC [aut], Jeff Allen [cre], Frans van Dunné [ctb], Sebastiaan Vandewoude [ctb], SmartBear Software [ctb, cph] (swagger-ui) Maintainer: Jeff Allen Repository: CRAN Date/Publication: 2018-06-05 04:43:03 UTC plumber/man/0000755000176200001440000000000013304040260012463 5ustar liggesusersplumber/man/plumber.Rd0000644000176200001440000000172113304040260014421 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plumber.R \docType{data} \name{plumb} \alias{plumb} \alias{plumber} \title{Plumber Router} \format{An object of class \code{R6ClassGenerator} of length 24.} \usage{ plumb(file, dir = ".") plumber } \arguments{ \item{file}{The file to parse as the plumber router definition} \item{dir}{The directory containing the \code{plumber.R} file to parse as the plumber router definition. Alternatively, if an \code{entrypoint.R} file is found, it will take precedence and be responsible for returning a runnable Plumber router.} } \description{ Routers are the core request handler in plumber. A router is responsible for taking an incoming request, submitting it through the appropriate filters and eventually to a corresponding endpoint, if one is found. } \details{ See \url{http://www.rplumber.io/docs/programmatic/} for additional details on the methods available on this object. } \keyword{datasets} plumber/man/PlumberStatic.Rd0000644000176200001440000000056213304040260015533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plumber-static.R \docType{data} \name{PlumberStatic} \alias{PlumberStatic} \title{Static file router} \format{An object of class \code{R6ClassGenerator} of length 24.} \usage{ PlumberStatic } \description{ Creates a router that is backed by a directory of files on disk. } \keyword{datasets} plumber/man/forward.Rd0000644000176200001440000000077413304040260014426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plumber-step.R \name{forward} \alias{forward} \title{Forward Request to The Next Handler} \usage{ forward() } \description{ This function is used when a filter is done processing a request and wishes to pass control off to the next handler in the chain. If this is not called by a filter, the assumption is that the filter fully handled the request itself and no other filters or endpoints should be evaluated for this request. } plumber/man/serializers.Rd0000644000176200001440000000166013304040260015311 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/serializer-json.R, R/serializer-content-type.R, % R/serializer-html.R, R/serializer-htmlwidget.R, R/serializer.R \name{serializer_json} \alias{serializer_json} \alias{serializer_unboxed_json} \alias{serializer_content_type} \alias{serializer_html} \alias{serializer_htmlwidget} \alias{serializers} \title{Plumber Serializers} \usage{ serializer_json() serializer_unboxed_json() serializer_content_type(type) serializer_html() serializer_htmlwidget() } \arguments{ \item{type}{The value to provide for the \code{Content-Type} HTTP header.} } \description{ Serializers are used in Plumber to transform the R object produced by a filter/endpoint into an HTTP response that can be returned to the client. See \href{https://book.rplumber.io/rendering-and-output.html#serializers}{here} for more details on Plumber serializers and how to customize their behavior. } plumber/man/do_configure_https.Rd0000644000176200001440000000444713305334567016671 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_configure_https} \alias{do_configure_https} \title{Add HTTPS to a plumber Droplet} \usage{ do_configure_https(droplet, domain, email, termsOfService = FALSE, force = FALSE) } \arguments{ \item{droplet}{The droplet on which to act. See \code{\link[analogsea:droplet]{analogsea::droplet()}}.} \item{domain}{The domain name associated with this instance. Used to obtain a TLS/SSL certificate.} \item{email}{Your email address; given only to letsencrypt when requesting a certificate to enable them to contact you about issues with renewal or security.} \item{termsOfService}{Set to \code{TRUE} to agree to the letsencrypt subscriber agreement. At the time of writing, the current version is available \href{https://letsencrypt.org/documents/LE-SA-v1.1.1-August-1-2016.pdf}{here}. Must be set to true to obtain a certificate through letsencrypt.} \item{force}{If \code{FALSE}, will abort if it believes that the given domain name is not yet pointing at the appropriate IP address for this droplet. If \code{TRUE}, will ignore this check and attempt to proceed regardless.} } \description{ Adds TLS/SSL (HTTPS) to a droplet created using \code{\link[=do_provision]{do_provision()}}. } \details{ In order to get a TLS/SSL certificate, you need to point a domain name to the IP address associated with your droplet. If you don't already have a domain name, you can register one \href{http://tres.tl/domain}{here}. Point a (sub)domain to the IP address associated with your plumber droplet before calling this function. These changes may take a few minutes or hours to propagate around the Internet, but once complete you can then execute this function with the given domain to be granted a TLS/SSL certificate for that domain. Obtains a free TLS/SSL certificate from \href{https://letsencrypt.org/}{letsencrypt} and installs it in nginx. It also configures nginx to route all unencrypted HTTP traffic (port 80) to HTTPS. Your TLS certificate will be automatically renewed and deployed. It also opens port 443 in the firewall to allow incoming HTTPS traffic. Historically, HTTPS certificates required payment in advance. If you appreciate this service, consider \href{https://letsencrypt.org/donate/}{donating to the letsencryptproject}. } plumber/man/do_remove_forward.Rd0000644000176200001440000000116613304040260016461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_remove_forward} \alias{do_remove_forward} \title{Remove the forwarding rule} \usage{ do_remove_forward(droplet) } \arguments{ \item{droplet}{The droplet on which to act. It's expected that this droplet was provisioned using \code{\link[=do_provision]{do_provision()}}. See \code{\link[analogsea:droplet]{analogsea::droplet()}} to obtain a reference to a running droplet.} } \description{ Removes the forwarding rule from the root path on the server. The server will no longer forward requests for \code{/} to an application. } plumber/man/do_deploy_api.Rd0000644000176200001440000000336713304040260015572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_deploy_api} \alias{do_deploy_api} \title{Deploy or Update an API} \usage{ do_deploy_api(droplet, path, localPath, port, forward = FALSE, swagger = FALSE, preflight) } \arguments{ \item{droplet}{The droplet on which to act. It's expected that this droplet was provisioned using \code{\link[=do_provision]{do_provision()}}. See \code{\link[analogsea:droplet]{analogsea::droplet()}} to obtain a reference to a running droplet.} \item{path}{The remote path/name of the application} \item{localPath}{The local path to the API that you want to deploy. The entire directory referenced will be deployed, and the \code{plumber.R} file inside of that directory will be used as the root plumber file. The directory MUST contain a \code{plumber.R} file.} \item{port}{The internal port on which this service should run. This will not be user visible, but must be unique and point to a port that is available on your server. If unsure, try a number around \code{8000}.} \item{forward}{If \code{TRUE}, will setup requests targeting the root URL on the server to point to this application. See the \code{\link[=do_forward]{do_forward()}} function for more details.} \item{swagger}{If \code{TRUE}, will enable the Swagger interface for the remotely deployed API. By default, the interface is disabled.} \item{preflight}{R commands to run after \code{\link[=plumb]{plumb()}}ing the \code{plumber.R} file, but before \code{run()}ing the plumber service. This is an opportunity to e.g. add new filters. If you need to specify multiple commands, they should be semi-colon-delimited.} } \description{ Deploys an API from your local machine to make it available on the remote plumber server. } plumber/man/addSerializer.Rd0000644000176200001440000000114413304040260015534 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/serializer.R \name{addSerializer} \alias{addSerializer} \title{Add a Serializer} \usage{ addSerializer(name, serializer) } \arguments{ \item{name}{The name of the serializer (character string)} \item{serializer}{The serializer to be added.} } \description{ A serializer is responsible for translating a generated R value into output that a remote user can understand. For instance, the \code{serializer_json} serializes R objects into JSON before returning them to the user. The list of available serializers in plumber is global. } plumber/man/sessionCookie.Rd0000644000176200001440000000125713304040260015574 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/session-cookie.R \name{sessionCookie} \alias{sessionCookie} \title{Store session data in encrypted cookies.} \usage{ sessionCookie(key, name = "plumber", ...) } \arguments{ \item{key}{The secret key to use. This must be consistent across all sessions where you want to save/restore encrypted cookies. It should be a long and complex character string to bolster security.} \item{name}{The name of the cookie in the user's browser.} \item{...}{Arguments passed on to the \code{response$setCookie} call to, for instance, set the cookie's expiration.} } \description{ Store session data in encrypted cookies. } plumber/man/PlumberEndpoint.Rd0000644000176200001440000000054313304040260016063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plumber-step.R \docType{data} \name{PlumberEndpoint} \alias{PlumberEndpoint} \title{Plumber Endpoint} \format{An object of class \code{R6ClassGenerator} of length 24.} \usage{ PlumberEndpoint } \description{ Defines a terminal handler in a PLumber router. } \keyword{datasets} plumber/man/include_file.Rd0000644000176200001440000000177113304040260015402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/includes.R \name{include_file} \alias{include_file} \alias{include_html} \alias{include_md} \alias{include_rmd} \title{Send File Contents as Response} \usage{ include_file(file, res, content_type) include_html(file, res) include_md(file, res, format = NULL) include_rmd(file, res, format = NULL) } \arguments{ \item{file}{The path to the file to return} \item{res}{The response object into which we'll write} \item{content_type}{If provided, the given value will be sent as the \code{Content-type} header in the response.} \item{format}{Passed as the \code{output_format} to \code{rmarkdown::render}} } \description{ Returns the file at the given path as the response. } \details{ \code{include_html} will merely return the file with the proper \code{content_type} for HTML. \code{include_md} and \code{include_rmd} will process the given markdown file through \code{rmarkdown::render} and return the resultant HTML as a response. } plumber/man/do_forward.Rd0000644000176200001440000000073713304040260015107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_forward} \alias{do_forward} \title{Forward Root Requests to an API} \usage{ do_forward(droplet, path) } \arguments{ \item{droplet}{The droplet on which to act. It's expected that this droplet was provisioned using \code{\link[=do_provision]{do_provision()}}.} \item{path}{The path to which root requests should be forwarded} } \description{ Forward Root Requests to an API } plumber/man/do_remove_api.Rd0000644000176200001440000000145613304040260015570 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_remove_api} \alias{do_remove_api} \title{Remove an API from the server} \usage{ do_remove_api(droplet, path, delete = FALSE) } \arguments{ \item{droplet}{The droplet on which to act. It's expected that this droplet was provisioned using \code{\link[=do_provision]{do_provision()}}. See \code{\link[analogsea:droplet]{analogsea::droplet()}} to obtain a reference to a running droplet.} \item{path}{The path/name of the plumber service} \item{delete}{If \code{TRUE}, will also delete the associated directory (\code{/var/plumber/whatever}) from the server.} } \description{ Removes all services and routing rules associated with a particular service. Optionally purges the associated API directory from disk. } plumber/man/do_provision.Rd0000644000176200001440000000414013304040260015463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digital-ocean.R \name{do_provision} \alias{do_provision} \title{Provision a DigitalOcean plumber server} \usage{ do_provision(droplet, unstable = FALSE, example = TRUE, ...) } \arguments{ \item{droplet}{The DigitalOcean droplet that you want to provision (see \code{\link[analogsea:droplet]{analogsea::droplet()}}). If empty, a new DigitalOcean server will be created.} \item{unstable}{If \code{FALSE}, will install plumber from CRAN. If \code{TRUE}, will install the unstable version of plumber from GitHub.} \item{example}{If \code{TRUE}, will deploy an example API named \code{hello} to the server on port 8000.} \item{...}{Arguments passed into the \code{\link[analogsea:droplet_create]{analogsea::droplet_create()}} function.} } \description{ Create (if required), install the necessary prerequisites, and deploy a sample plumber application on a DigitalOcean virtual machine. You may sign up for a Digital Ocean account \href{https://m.do.co/c/add0b50f54c4}{here}. This command is idempotent, so feel free to run it on a single server multiple times. } \details{ Provisions a Ubuntu 16.04-x64 droplet with the following customizations: \itemize{ \item A recent version of R installed \item plumber installed globally in the system library \item An example plumber API deployed at \code{/var/plumber} \item A systemd definition for the above plumber API which will ensure that the plumber API is started on machine boot and respawned if the R process ever crashes. On the server you can use commands like \code{systemctl restart plumber} to manage your API, or \code{journalctl -u plumber} to see the logs associated with your plumber process. \item The `nginx`` web server installed to route web traffic from port 80 (HTTP) to your plumber process. \item \code{ufw} installed as a firewall to restrict access on the server. By default it only allows incoming traffic on port 22 (SSH) and port 80 (HTTP). \item A 4GB swap file is created to ensure that machines with little RAM (the default) are able to get through the necessary R package compilations. } } plumber/LICENSE0000644000176200001440000000006513304040260012716 0ustar liggesusersYEAR: 2016 COPYRIGHT HOLDER: Trestle Technology, LLC