Figure out shiny integration

[hadley]

r-lib/gargle#157

• Need to ensure that expiry is a parameter of the setup; the current default sets the lifetime to null, which means that the cookies will be expired on next log in.
• Cookies are encrypted so that they can't be read by browser; need to double check encryption if there's no client secret. Might be adequate to encrypt with common httr2 key?
• Double check that cookies are scoped to given path so they only apply for one app.
• PR to shiny to provide https://github.com/r-lib/gargle/pull/157/files#diff-169b8f234d0b208affb106fce375f86fefe2f16dba4ad66495a1dc06c8a4cd7bR145-R185

Code in PR currently uses OAuth as gate to access app; might also want to use it as optional feature (i.e. log in to save this file to your google drive), so will also need to work out that flow.

[hadley]

Some more notes

---

Optional auth:

• User clicks button, and is redirected to oauth_flow_auth_code_url()
  • OAuth "state" stored in cookie
  • Set redirect_uri to {my_url}/login
• After logging in to resource server, redirected to /login with code in query string
  • If error, need to display to user somehow
  • Then compare state in query to state in cookie
  • Retrive token, encrypt, and store in cookie
• Redirect back to app
  • Need to update UI and store token in reactive?

# What needs to go outside?
#   * registering login and logout endpoints
#   * capturing token into userData?
library(shiny)

# Not reactive because it can't change within a session; cookies have to
# change which requires a new connection
token <- oauth_session_token() 
# Shortcut for getDefaultReactiveDomain()$userData$httr2_token
# with appropriate error handling
# Could parse from ...$request$COOKIE_HEADER but that's not available on shinyapps

# Dynamic UI - in principle could also do this from ui() function since
# cookie header will indicate whether or not its available
input$tweet <- renderUI({
  if (is.null(token())) {
    actionButton("login", "Log in with twitter to tweet about this")
  } else {
    activeButton("save", "Send tweet")
  }
})

observeEvent(input$save, {
  # How does re-auth work? Don't want to redirect user away if that loses state
  # Would it be better to do via js in a child window?
  request() %>% req_oauth_shiny_auth_code()
  # could call oauth_session_token() or could make that explicit
})

observeEvent(input$login, {
  # how to redirect?
})

• How does a package developer facilitate auth either via command line or via shiny? Add flag to request object?

token_from_cookies <- function(req) {
  cookies <- parse_cookies(req[["HTTP_COOKIE"]])
  secret_unserialize(cookies$token, obfuscate_key())
}

response_login <- function(redirect, state, cookie_opts) {
  headers <- list(
    "Cache-Control" = "no-store",
    `Set-Cookie` = cookie_set("httr2_state", state, cookie_opts),
  )
  response_redirect(redirect, headers)
}

response_oauth_callback <- function(redirect_url, token, cookie_opts) {
  token <- secret_serialize(token, obfuscate_key())
  
  headers <- list(
    "Cache-Control" = "no-store",
    `Set-Cookie` = cookie_del("httr2_state", cookie_opts),
    `Set-Cookie` = cookie_set("httr2_token", token, cookie_opts),
  )
  # But maybe this doesn't work - because it adds an extra redirect
  response_redirect("./", headers)
}

response_logout <- function(cookie_opts) {
  headers <- list2(
    `Cache-Control` = "no-store",
    `Set-Cookie` = cookie_del("httr2_token", cookie_opts),
  )
  response_redirect("./", header)
}

response_redirect <- function(url, headers) {
  shiny::httpResponse(
    status = 307L,
    content_type = NULL,
    headers = c(list(Location = url), headers)
  )
}

[thohan88]

I recently had to implement something similar to your second scenario (not using OAuth as gate to access app, but to retrieve an access token to fetch data inside app, e.g. from Github). I don't know if it's helpful, but I'm leaving my notes here.

I opted to not go for the uifunc-approach (passing ui as a function as shown in the gargle PR), but instead doing everything from the server side using cookies, which had some gotchas:

• Localhost Redirect URI and cookies: Shiny needs to run at a valid IP4 or IP6-address, which means you can't actually pass host = 'localhost'. I naively assumed 127.0.0.1 and localhost were equivalent, but the browser treats them as different domains. So if your redirect URI is set as localhost, a cookie set at 127.0.0.1 would not be available after redirection to localhost. The solution is to set redirect URI to 127.0.0.1, and never use localhost. This took me hours.

• Setting session cookies: I could not find a good way to set this from the server side at first (see #3524). I figured I could do this by "abusing" the session$registerDataObj which can pass a shiny::httpResponse, but I could not find a way to actually trigger this until I discovered the trick of just passing the endpoint to InsertUI. Works great, but feels a bit hacky. After the redirect, the cookies are available in session$request$HTTP_COOKIE

• Redirecting from server side: I tried to use the same method as for cookies (session$registerDataObj) and passing status 307 and location to shiny::httpResponse similarly to the gargle PR . This kept giving CORS-errors which I believe is due to the XHR having rich headers which I was unable to remove. In the end, I went for a custom message using Shiny.addCustomMessageHandler... and window.location which seems to be the recommended way to go, but I would have preferred using httpResponse. Maybe @jcheng5 could comment.

• Splitting up the oauth flow: Compared to the family of req_oauth_* functions, this approach requires the logic to be splitted into two parts. I am sure better abstractions could be found here, and I'm still trying to find the best approach for tying it together, anyways:

  • Trigger flow using observeEvent(input$login_btn), set cookies and redirect
  • Catch redirect using observeEvent(session$clientData$url_search), retrieve cookie, verify state and PKCE and fetch token

• Requires launch.browser=TRUE: Due to the redirect.

Here is a minimal app where I'm just verifying state. This was easy to extend to PKCE by just adding an encrypted PKCE_COOKIE and verifying the same way.

app.R

library(shiny)
library(httr2)
source("utils.R")

client <- oauth_client(
  id = "",
  secret = "",
  token_url = "https://github.com/login/oauth/access_token",
  name = "OAuth Test APP"
)

authorize_url <- "https://github.com/login/oauth/authorize"
redirect_uri <- "http://127.0.0.1:1410"

ui <- fluidPage(
  tags$script('Shiny.addCustomMessageHandler("redirect", function(msg) {
  window.location.href = (msg);
              });'),
  titlePanel("OAuth2 Github"),
  mainPanel(
    h4("Log in:"),
    actionButton("login", "Login"),
    h4("Access token"), 
    verbatimTextOutput("token", placeholder = TRUE)
  )
)

server <- function(input, output, session) {
  
  access_token <- reactiveVal()
  
  observeEvent(input$login, {
    oauth_state <- httr2:::base64_url_rand()
    
    set_cookie(session, "oauth_state", oauth_state)
    
    auth_url <- oauth_flow_auth_code_url(
      client = client, 
      auth_url = authorize_url, 
      redirect_uri = redirect_uri,
      state = oauth_state)
    
    session$sendCustomMessage("redirect", auth_url)
  })
  
  observeEvent(session$clientData$url_search, {
    query <- parseQueryString(session$clientData$url_search)
    if (!is.null(query$code) && !is.null(query$state)) {
      
      state <- get_cookie(session, "oauth_state")
      code <- httr2:::oauth_flow_auth_code_parse(query, state)
      token <- httr2:::oauth_client_get_token(
        client = client,
        grant_type = "authorization_code",
        code = query$code,
        state = query$state)
      
      updateQueryString("/", mode = "replace", session = session)
      
      access_token(token)
    }
  })
  
  output$token <- renderText({
    req(access_token())
    paste0(substring(access_token()$access_token, 1, 5), "***************")
  })
}

shinyApp(ui, server = server, options = list(port = 1410, launch.browser = TRUE))

I used some wrappers for the cookie handling, in addition to the cookie functions in the gargle PR

utils.R

get_cookie <- function(session, name) {
  parse_cookies(session$request)[[name]]
}

set_cookie <- function(session, name, value){
  manage_cookie(session, "set", name, value)
}

del_cookie <- function(session, name){
  manage_cookie(session, "del", name)
}

manage_cookie <- function(session, type = c("set", "del"), name, value) {
  
  cookie_opts <- list(path = "/", same_site = "None", secure = TRUE)
  
  if(type == "set") {
    hdr <- set_cookie_header(name, value, cookie_opts)
  } else {
    hdr <- delete_cookie_header(name, cookie_opts)
  }
  
  script_url <- session$registerDataObj(
    name = paste("type", "cookie", httr2:::base64_url_rand(), sep = "_"),
    data = httpResponse(headers = hdr),
    filterFunc = function(data, req) {data}
  )
  
  # Trigger cookie
  # Adopted from: https://github.com/andyquinterom/keycloakAuthR/blob/be24d05c39ed2eb18e6c3fc7d4f1ca14421ad4a5/R/shiny.R#L149 
  insertUI(
    "body",
    where = "afterBegin",
    ui = tagList(tags$script(src = script_url)),
    immediate = TRUE,
    session = session
  )
}

# Remaining functions are from Gargle PR
# https://github.com/r-lib/gargle/blob/bd35392da45b271e5199ccbe28fb766135712461/R/shiny-cookies.R

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))
  
  stats::setNames(as.list(values), names)
}

cookie_options <- function(max_age = NULL, domain = NULL, path = NULL,
                           secure = NULL, http_only = TRUE, same_site = NULL, expires = 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) || isFALSE(secure))
  if (isFALSE(secure)) {
    secure <- NULL
  }
  stopifnot(is.null(http_only) || isTRUE(http_only) || isFALSE(http_only))
  if (isFALSE(http_only)) {
    http_only <- NULL
  }
  
  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))
  header <- paste(collapse = "; ", paste0(names, sep, values))
  list("Set-Cookie" = header)
}

# Returns a list, suitable for `!!!`-ing into a list of HTTP headers
delete_cookie_header <- function(name, cookie_options = cookie_options()) {
  cookie_options[["Expires"]] <- NULL
  cookie_options[["Max-Age"]] <- 0
  set_cookie_header(name, "", cookie_options)
}

Thanks for httr2! It's an awesome package and you can tell a lot of thought has gone into making great APIs for users 👍

[khaled-alshamaa]

Thanks a lot @thohan88 for the minimal example you shared, it is super helpful and provides a practical approach to tackle this issue. My question is regarding the scenario with PKCE, say I used the httr2::oauth_flow_auth_code_pkce() function to generate code verifier, method, and challenge PKCE components, then I used cookies (e.g., PKCE_COOKIE) to save/retrieve them. How should we alter the get token function call to work in this scenario? I tried the following with no success :-(

token <- httr2:::oauth_client_get_token(client = client,
                                        grant_type = "authorization_code",
                                        code = query$code,
                                        state = query$state,
                                        code_verifier = pkce$verifier)

It is not clear to me what other token_params I have to pass in this function parameters. I believe both code_challenge and code_challenge_method PKCE components are belongs to the auth_params list, not token_params (httr2/R/oauth-flow-auth-code.R source code). I will highly appreciate it if you can help me find what I miss in this puzzle :-)

NOTE: When I set the grant_type = "authorization_code_with_pkce", I get an OAuth failure [unsupported_grant_type]

[thohan88]

Your intuition is right, I will see if I can come up with a better structure now that I have gotten my head around it.

Meanwhile, I think this should work:

Before redirect

0. Set a key for encrypting the verifier for PKCE that does not vary by session (e.g. don't use secret_make_key()):

Sys.setenv("MY_KEY" = "VERY_SECRET_KEY")

1. Set a cookie for the encrypted pkce_verifier at the same place you set the state cookie, e.g:

 oauth_state <- httr2:::base64_url_rand()
+pkce <- oauth_flow_auth_code_pkce()

 set_cookie(session, "oauth_state", oauth_state)
+set_cookie(session, "pkce_verifier", secret_encrypt(pkce$verifier, "MY_KEY"))

2. Now, modify the auth_url to include PKCE challenge and method:

auth_url <- oauth_flow_auth_code_url(
  client = client, 
  auth_url = authorize_url, 
  redirect_uri = redirect_uri,
  state = oauth_state,
  auth_params = list(
    scope = scopes,
+   code_challenge = pkce$challenge, 
+   code_challenge_method = pkce$method
  )
)

After redirect

3. Retrieve the PKCE verifier and decrypt the same place as you retrieve state

 state <- get_cookie(session, "oauth_state")
+pkce_verifier <- get_cookie(session, "pkce_verifier") |> secret_decrypt("MY_KEY")

4. Include it when you ask for a token

token <- httr2:::oauth_client_get_token(
  client,
  code = code,
  grant_type = "authorization_code",
  redirect_uri = redirect_uri,
+ code_verifier = pkce_verifier
)

If it does not work, set a browser() right before oauth_client_get_token() and observe your input. Good luck!

[JosiahParry]

The new package {shinyOAuth} makes this possible. The docs are incredibly terse but it works surprisingly well! I believe it uses cookies like suggested in this issue. Here's their shinyOAuth.js

Here's a draft of how I'm using it in {arcgisutils}: https://github.com/R-ArcGIS/arcgisutils/blob/e9aa6f87cdcb3b5f8df64463f3b92d652876e98a/R/auth-shiny.R