-
Notifications
You must be signed in to change notification settings - Fork 33
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Shiny integration #157
base: main
Are you sure you want to change the base?
Shiny integration #157
Changes from 5 commits
e538f06
c766744
6e2f71b
c2c9feb
132d549
97b10eb
9c44358
5d8d2c5
4bfc29f
d0112ca
6aee032
1025134
83c3e19
bd35392
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change | ||||
---|---|---|---|---|---|---|
@@ -0,0 +1,324 @@ | ||||||
#' @export | ||||||
require_oauth <- function(app, oauth_app, scopes, welcome_ui, | ||||||
cookie_opts = cookie_options(http_only = TRUE)) { | ||||||
|
||||||
force(oauth_app) | ||||||
force(scopes) | ||||||
force(welcome_ui) | ||||||
|
||||||
httpHandler <- app$httpHandler | ||||||
app$httpHandler <- function(req) { | ||||||
resp <- | ||||||
handle_oauth_callback(req, oauth_app, cookie_opts) %||% | ||||||
handle_logged_in(req, oauth_app, httpHandler) %||% | ||||||
handle_welcome(req, oauth_app, scopes, cookie_opts) | ||||||
resp | ||||||
} | ||||||
|
||||||
serverFuncSource <- app$serverFuncSource | ||||||
app$serverFuncSource <- function() { | ||||||
wrappedServer <- serverFuncSource() | ||||||
function(input, output, session) { | ||||||
creds <- read_creds_from_cookies(session$request, oauth_app) | ||||||
if (is.null(creds)) { | ||||||
stop("gargle_token cookie expected but not found") | ||||||
} else { | ||||||
email <- jwt_decode(creds[["id_token"]])[["claim"]][["email"]] | ||||||
stopifnot(is.character(email) && length(email) == 1) | ||||||
|
||||||
token <- gargle2.0_token(email, oauth_app, package = "gargle", | ||||||
scope = creds$scope, credentials = creds) | ||||||
session$userData$gargle_token <- token | ||||||
wrappedServer(input, output, session) | ||||||
} | ||||||
} | ||||||
} | ||||||
|
||||||
app | ||||||
} | ||||||
|
||||||
handle_oauth_callback <- function(req, oauth_app, cookie_opts) { | ||||||
if (has_code_param(req)) { | ||||||
# User just completed login; verify, set cookie, and redirect | ||||||
cookies <- parse_cookies(req) | ||||||
gargle_auth_state <- cookies[["gargle_auth_state"]] | ||||||
if (!is.null(gargle_auth_state)) { | ||||||
qs <- shiny::parseQueryString(req[["QUERY_STRING"]]) | ||||||
code <- qs$code | ||||||
state <- qs$state | ||||||
|
||||||
if (identical(state, gargle_auth_state)) { | ||||||
cred <- httr::oauth2.0_access_token( | ||||||
gargle_outh_endpoint(), | ||||||
app = oauth_app, | ||||||
code = code, | ||||||
redirect_uri = infer_app_url(req) | ||||||
) | ||||||
|
||||||
# cred has: | ||||||
# access_token, expires_in, scope, token_type, and id_token | ||||||
# (and possibly refresh_token) | ||||||
|
||||||
return(shiny::httpResponse( | ||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Is there a Shiny reason to use an explicit There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I often use explicit I know @hadley tends to only use them when necessary, we have a difference of opinion here. This being your package, I'm happy to adhere to whatever style you prefer. |
||||||
status = 307L, | ||||||
content_type = "text/plain", | ||||||
content = "", | ||||||
headers = rlang::list2( | ||||||
Location = infer_app_url(req), | ||||||
"Cache-Control" = "no-store", | ||||||
!!!delete_cookie_header("gargle_auth_state", cookie_opts), | ||||||
!!!set_cookie_header("gargle_token", wrap_creds(cred, oauth_app), | ||||||
cookie_opts) | ||||||
) | ||||||
)) | ||||||
} | ||||||
} | ||||||
} | ||||||
} | ||||||
|
||||||
handle_logged_in <- function(req, oauth_app, httpHandler) { | ||||||
if (!is.null(read_creds_from_cookies(req, oauth_app))) { | ||||||
# User is already logged in, proceed | ||||||
return(httpHandler(req)) | ||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Same question as above re: |
||||||
} | ||||||
} | ||||||
|
||||||
handle_welcome <- function(req, oauth_app, scopes, cookie_opts) { | ||||||
redirect_uri <- infer_app_url(req) | ||||||
state <- sodium::bin2hex(sodium::random(32)) | ||||||
query_extra <- list( | ||||||
access_type = "offline" | ||||||
) | ||||||
|
||||||
# TODO: Add email? | ||||||
|
||||||
auth_url <- httr::oauth2.0_authorize_url( | ||||||
endpoint = gargle_outh_endpoint(), | ||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more.
Suggested change
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Actually the way I have it is "correct" 😬 I'm happy to fix the actual function in a separate PR if you like? There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. 😱 There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Fixed in 848663b, so you can merge/rebase |
||||||
oauth_app, | ||||||
scope = paste(scopes, collapse = " "), | ||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Elsewhere, gargle always adds the Line 138 in 1bab80c
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. The There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Those considerations don't apply here, but I also think there's no reason not to; the Google consent screen doesn't even mention the email and profile scopes, whether you include them or not. There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Yeah, thus far at least, the Can you amplify on why this scope would never be handy in a Shiny context, the way it is elsewhere? There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. The reason email doesn't matter for Shiny, is because Shiny never stores multiple tokens in one place, like the gargle cache does, and thus there never needs to be any way to identify or compare a token (i.e. no need to call There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I think the reason to get this scope is also for the sake of the client package and, potentially, Shiny app -- so not just about labelling tokens in a store. It seems this could be needed to, for example, show the user who they are logged in as. There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Sounds good. This'll be in the next commit I make. |
||||||
redirect_uri = redirect_uri, | ||||||
state = state, | ||||||
query_extra = query_extra) | ||||||
|
||||||
shiny::httpResponse( | ||||||
status = 307L, | ||||||
content_type = NULL, | ||||||
content = "", | ||||||
headers = rlang::list2( | ||||||
Location = auth_url, | ||||||
"Cache-Control" = "no-store", | ||||||
!!!set_cookie_header("gargle_auth_state", state, cookie_opts) | ||||||
) | ||||||
) | ||||||
} | ||||||
|
||||||
read_creds_from_cookies <- function(req, oauth_app) { | ||||||
cookies <- parse_cookies(req) | ||||||
gargle_token <- cookies[["gargle_token"]] | ||||||
if (!is.null(gargle_token)) { | ||||||
unwrap_creds(gargle_token, oauth_app) | ||||||
} | ||||||
} | ||||||
|
||||||
wrap_creds <- function(creds, oauth_app) { | ||||||
cred_str <- jsonlite::toJSON(creds, auto_unbox = TRUE) | ||||||
|
||||||
oauth_app_str <- enc2utf8(paste(oauth_app$secret, oauth_app$key)) | ||||||
|
||||||
salt <- sodium::random(32) | ||||||
nonce <- sodium::random(24) | ||||||
key <- sodium::scrypt(charToRaw(oauth_app_str), salt = salt, size = 32) | ||||||
ciphertext <- sodium::data_encrypt(charToRaw(cred_str), key = key, nonce = nonce) | ||||||
|
||||||
sodium::bin2hex(c(salt, nonce, ciphertext)) | ||||||
} | ||||||
|
||||||
unwrap_creds <- function(gargle_token, oauth_app) { | ||||||
if (is.null(gargle_token)) { | ||||||
return(NULL) | ||||||
} | ||||||
|
||||||
tryCatch({ | ||||||
oauth_app_str <- paste(oauth_app$secret, oauth_app$key) | ||||||
|
||||||
bytes <- sodium::hex2bin(gargle_token) | ||||||
|
||||||
if (length(bytes) <= 32 + 24) { | ||||||
stop(call. = FALSE, "gargle cookie payload was too short") | ||||||
} | ||||||
|
||||||
salt <- bytes[1:32] | ||||||
nonce <- bytes[32 + (1:24)] | ||||||
rest <- tail(bytes, -(32 + 24)) | ||||||
|
||||||
key <- sodium::scrypt(charToRaw(oauth_app_str), salt = salt, size = 32) | ||||||
cleartext <- sodium::data_decrypt(rest, key = key, nonce = nonce) | ||||||
cleartext <- rawToChar(cleartext) | ||||||
Encoding(cleartext) <- "UTF-8" | ||||||
|
||||||
jsonlite::parse_json(cleartext) | ||||||
}, error = function(err) { | ||||||
ui_line("gargle cookie failed to decrypt: ", conditionMessage(err)) | ||||||
return(NULL) | ||||||
}) | ||||||
} | ||||||
|
||||||
has_code_param <- function(req) { | ||||||
qs <- shiny::parseQueryString(req[["QUERY_STRING"]]) | ||||||
"code" %in% names(qs) | ||||||
} | ||||||
|
||||||
infer_app_url <- function(req) { | ||||||
|
||||||
url <- | ||||||
# Connect | ||||||
req[["HTTP_X_RSC_REQUEST"]] %||% | ||||||
req[["HTTP_RSTUDIO_CONNECT_APP_BASE_URL"]] %||% | ||||||
# ShinyApps.io | ||||||
if (!is.null(req[["HTTP_X_REDX_FRONTEND_NAME"]])) { paste0("https://", req[["HTTP_X_REDX_FRONTEND_NAME"]]) } | ||||||
|
||||||
if (is.null(url)) { | ||||||
forwarded_host <- req[["HTTP_X_FORWARDED_HOST"]] | ||||||
forwarded_port <- req[["HTTP_X_FORWARDED_PORT"]] | ||||||
|
||||||
host <- if (!is.null(forwarded_host) && !is.null(forwarded_port)) { | ||||||
paste0(forwarded_host, ":", forwarded_port) | ||||||
} else { | ||||||
req[["HTTP_HOST"]] %||% paste0(req[["SERVER_NAME"]], ":", req[["SERVER_PORT"]]) | ||||||
} | ||||||
|
||||||
proto <- req[["HTTP_X_FORWARDED_PROTO"]] %||% req[["rook.url_scheme"]] | ||||||
|
||||||
if (tolower(proto) == "http") { | ||||||
host <- sub(":80$", "", host) | ||||||
} else if (tolower(proto) == "https") { | ||||||
host <- sub(":443$", "", host) | ||||||
} | ||||||
|
||||||
url <- paste0( | ||||||
proto, | ||||||
"://", | ||||||
host, | ||||||
req[["SCRIPT_NAME"]], | ||||||
req[["PATH_INFO"]] | ||||||
) | ||||||
} | ||||||
|
||||||
# Strip existing querystring, if any | ||||||
url <- sub("\\?.*", "", url) | ||||||
|
||||||
url | ||||||
} | ||||||
|
||||||
parse_cookies <- function(req) { | ||||||
cookie_header <- req[["HTTP_COOKIE"]] | ||||||
if (is.null(cookie_header)) { | ||||||
return(NULL) | ||||||
} | ||||||
|
||||||
cookies <- strsplit(cookie_header, "; *")[[1]] | ||||||
m <- regexec("(.*?)=(.*)", cookies) | ||||||
matches <- regmatches(cookies, m) | ||||||
names <- vapply(matches, function(x) { | ||||||
if (length(x) == 3) { | ||||||
x[[2]] | ||||||
} else { | ||||||
"" | ||||||
} | ||||||
}, character(1)) | ||||||
|
||||||
if (any(names == "")) { | ||||||
# Malformed cookie | ||||||
return(NULL) | ||||||
} | ||||||
|
||||||
values <- vapply(matches, function(x) { | ||||||
x[[3]] | ||||||
}, character(1)) | ||||||
|
||||||
setNames(as.list(values), names) | ||||||
} | ||||||
|
||||||
#' @export | ||||||
cookie_options <- function(expires = NULL, max_age = NULL, | ||||||
domain = NULL, path = NULL, secure = NULL, http_only = NULL, same_site = NULL) { | ||||||
|
||||||
if (!is.null(expires)) { | ||||||
stopifnot(length(expires) == 1 && (inherits(expires, "POSIXt") || is.character(expires))) | ||||||
if (inherits(expires, "POSIXt")) { | ||||||
expires <- as.POSIXlt(expires, tz = "GMT") | ||||||
expires <- sprintf("%s, %02d %s %04d %02d:%02d:%02.0f GMT", | ||||||
c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")[[expires$wday + 1]], | ||||||
expires$mday, | ||||||
c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")[[expires$mon + 1]], | ||||||
expires$year + 1900, | ||||||
expires$hour, | ||||||
expires$min, | ||||||
expires$sec | ||||||
) | ||||||
} | ||||||
} | ||||||
|
||||||
stopifnot(is.null(max_age) || (is.numeric(max_age) && length(max_age) == 1)) | ||||||
if (!is.null(max_age)) { | ||||||
max_age <- sprintf("%.0f", max_age) | ||||||
} | ||||||
stopifnot(is.null(domain) || (is.character(domain) && length(domain) == 1)) | ||||||
stopifnot(is.null(path) || (is.character(path) && length(path) == 1)) | ||||||
stopifnot(is.null(secure) || isTRUE(secure)) | ||||||
stopifnot(is.null(http_only) || isTRUE(http_only)) | ||||||
|
||||||
stopifnot(is.null(same_site) || (is.character(same_site) && length(same_site) == 1 && | ||||||
grepl("^(strict|lax|none)$", same_site, ignore.case = TRUE))) | ||||||
# Normalize case | ||||||
if (!is.null(same_site)) { | ||||||
same_site <- c(strict = "Strict", lax = "Lax", none = "None")[[tolower(same_site)]] | ||||||
} | ||||||
|
||||||
list( | ||||||
"Expires" = expires, | ||||||
"Max-Age" = max_age, | ||||||
"Domain" = domain, | ||||||
"Path" = path, | ||||||
"Secure" = secure, | ||||||
"HttpOnly" = http_only, | ||||||
"SameSite" = same_site | ||||||
) | ||||||
} | ||||||
|
||||||
set_cookie_header <- function(name, value, cookie_options = cookie_options()) { | ||||||
|
||||||
stopifnot(is.character(name) && length(name) == 1) | ||||||
stopifnot(is.null(value) || (is.character(value) && length(value) == 1)) | ||||||
value <- value %||% "" | ||||||
|
||||||
parts <- rlang::list2( | ||||||
!!name := value, | ||||||
!!!cookie_options | ||||||
) | ||||||
parts <- parts[!vapply(parts, is.null, logical(1))] | ||||||
|
||||||
names <- names(parts) | ||||||
sep <- ifelse(vapply(parts, isTRUE, logical(1)), "", "=") | ||||||
values <- ifelse(vapply(parts, isTRUE, logical(1)), "", as.character(parts)) | ||||||
list( | ||||||
"Set-Cookie" = paste(collapse = "; ", paste0(names, sep, values)) | ||||||
) | ||||||
} | ||||||
|
||||||
delete_cookie_header <- function(name, cookie_options = cookie_options()) { | ||||||
cookie_options[["Expires"]] <- NULL | ||||||
cookie_options[["Max-Age"]] <- 0 | ||||||
set_cookie_header(name, "", cookie_options) | ||||||
} | ||||||
|
||||||
jwt_decode <- function(jwt_str) { | ||||||
stopifnot(is.character(jwt_str) && length(jwt_str) == 1) | ||||||
pieces <- strsplit(jwt_str, ".", fixed = TRUE)[[1]] | ||||||
stopifnot(length(pieces) == 3) | ||||||
|
||||||
list( | ||||||
header = jsonlite::parse_json(rawToChar(base64enc::base64decode(pieces[[1]]))), | ||||||
claim = jsonlite::parse_json(rawToChar(base64enc::base64decode(pieces[[2]]))) | ||||||
) | ||||||
} |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,31 @@ | ||
library(shiny) | ||
library(googledrive) | ||
library(gargle) | ||
library(magrittr) | ||
|
||
oauth_scopes = c( | ||
"https://www.googleapis.com/auth/userinfo.email", | ||
"https://www.googleapis.com/auth/userinfo.profile", | ||
"https://www.googleapis.com/auth/spreadsheets", | ||
"https://www.googleapis.com/auth/drive.readonly" | ||
) | ||
|
||
oauth_app <- gargle_app() | ||
|
||
ui <- fluidPage( | ||
verbatimTextOutput("foo") | ||
) | ||
|
||
server <- function(input, output, session) { | ||
output$foo <- renderText({ | ||
# This is just temporary, we need to make this automatic. Written this way, | ||
# it's too easy to get wrong, and also won't work properly with promises | ||
drive_auth(token = session$userData$gargle_token) | ||
on.exit(drive_deauth()) | ||
|
||
listing <- googledrive::drive_find(n_max = 100) | ||
paste(collapse = "\n", capture.output(print(listing))) | ||
}) | ||
} | ||
|
||
shinyApp(ui, server) %>% require_oauth(oauth_app, oauth_scopes, NULL) |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
welcome_ui
is never used anywhere and, based purely on name, I wonder if maybe it goes here?There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Out of curiosity, why does
resp
need to be assigned?There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Yep,
welcome_ui
is not implemented yet but it will go there.I assigned
resp
for two pretty trivial reasons: 1) to get thehandle_*
calls to be all indented together, and 2) to make it clear that there's a return value here that matters (vs. callinghandle_*
invoking some side effect, which is the way many web frameworks work).