Add worker id info to state parameter

Should allow Connect/SSP to reliably route oauth handshakes
among multiple R processes for the same app

NAMESPACE

@@ -40,6 +40,7 @@ export(absolutePanel)
 export(actionButton)
 export(actionLink)
 export(addResourcePath)
+export(addRouteHandler)
 export(animationOptions)
 export(appendTab)
 export(as.shiny.appobj)

R/server.R

@@ -82,6 +82,16 @@ addResourcePath <- function(prefix, directoryPath) {
   )
 }
 
+#' @export
+addRouteHandler <- function(urlPath, handler) {
+  if (!is.function(handler)) {
+    stop("addHandlerPath handler must be a function")
+  }
+  .globals$userHandlers[[urlPath]] <- handler
+  invisible()
+}
+.globals$userHandlers <- list()
+
 # This function handles any GET request with two or more path elements where the
 # first path element matches a prefix that was previously added using
 # addResourcePath().
@@ -128,6 +138,17 @@ resourcePathHandler <- function(req) {
   return(resInfo$func(subreq))
 }
 
+userHandlersHandler <- function(req) {
+  # e.g. "/foo/one/two.html"
+  path <- req$PATH_INFO
+
+  handler <- .globals$userHandlers[[path]]
+  if (is.null(handler))
+    return(NULL)
+
+  return(..stacktraceon..(handler(req)))
+}
+
 #' Define Server Functionality
 #'
 #' Defines the server-side logic of the Shiny application. This generally
@@ -226,6 +247,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
+      userHandlersHandler,
       reactLogHandler
     )),
     ws = function(ws) {

examples/oauth/app.R

@@ -0,0 +1,81 @@
+library(shiny)
+
+options(shiny.port=8100)
+
+# TODO: Figure out how not to require shiny.port to be set in advance
+# TODO: Verify that cookies work in Connect/SSP
+# TODO: Whole-page protection behind oauth
+
+source("oauth.R")
+
+github_oauth_config <- oauth_config(
+  oauth_endpoint_uri = "https://github.com/login/oauth/authorize",
+  token_endpoint_uri = "https://github.com/login/oauth/access_token",
+  app_uri = "http://127.0.0.1:8100/",
+
+  # Store client_id and client_secret however you want--just hardcoded for this example
+  client_id = "700d40c400de637d9780",
+  client_secret = "e6383430779d9df9b253e7d6b1fb53308033873d",
+
+  scope = ""
+)
+
+google_oauth_config <- oauth_config(
+  oauth_endpoint_uri = "https://accounts.google.com/o/oauth2/v2/auth",
+  token_endpoint_uri = "https://www.googleapis.com/oauth2/v4/token",
+  app_uri = "http://127.0.0.1:8100/",
+
+  # Store client_id and client_secret however you want--just hardcoded for this example
+  client_id = "350280321053-7bq89pep4da46df2g66ddjnj6e3qrnie.apps.googleusercontent.com",
+  client_secret = "8_AHVNXyKyO3tBAZFAy-2y0B",
+
+  scope = "https://www.googleapis.com/auth/drive.metadata.readonly"
+)
+
+
+ui <- fluidPage(
+  textOutput("username", inline = TRUE),
+  p(
+    oauth_login_ui("oauth_login")
+  )
+)
+
+server <- function(input, output, session) {
+
+  ### GITHUB
+
+  token <- callModule(oauth_login, id = "oauth_login", github_oauth_config)
+
+  output$username <- renderText({
+    if (is.null(token())) {
+      "Not logged in"
+    } else {
+      resp <- httr::GET("https://api.github.com/user",
+        httr::add_headers("Authorization" = paste("token", token()))
+      )
+
+      paste0("Logged in as ", httr::content(resp)$login)
+    }
+  })
+
+
+
+  ## GOOGLE
+
+  # token <- callModule(oauth_login, id = "oauth_login", google_oauth_config)
+  #
+  # output$username <- renderText({
+  #   if (is.null(token())) {
+  #     # Not logged in
+  #     "(nobody)"
+  #   } else {
+  #     req <- gargle::request_build(method = "GET", path = "oauth2/v3/tokeninfo",
+  #       params = list(access_token=token()),
+  #       base_url = "https://www.googleapis.com")
+  #     resp <- gargle::request_make(req)
+  #     gargle::response_process(resp)$email
+  #   }
+  # })
+}
+
+shinyApp(ui, server, options = list(port = 8100))

examples/oauth/oauth.R

@@ -0,0 +1,293 @@
+# remotes::install_github("r-lib/fastmap")
+
+# Include in your Shiny UI wherever you want OAuth login UI to appear
+oauth_login_ui <- function(id) {
+  ns <- NS(id)
+  tagList(
+    uiOutput(ns("container")),
+    htmltools::singleton(tags$head(clear_cookie_custom_handler))
+  )
+}
+
+# A simple Bootstrap OAuth login button
+oauth_login_button <- function(login_url) {
+  #tags$a(href=login_url, target="_blank", class="btn btn-default", "Login")
+  tags$a(href=sprintf("javascript:window.open('%s');", login_url), class = "btn btn-default", "Login")
+}
+
+oauth_logout_button <- function(input_id) {
+  actionLink(input_id, "Logout")
+}
+
+oauth_do_logout <- function(rv, session = getDefaultReactiveDomain()) {
+  xsrf_token <- shiny:::createUniqueId(16)
+  clear_cookie_xsrf$set(xsrf_token, TRUE)
+
+  session$sendCustomMessage("oauth-clear-cookie-handler", list(
+    xsrf_token = xsrf_token
+  ))
+  rv(NULL)
+}
+
+oauth_config <- function(oauth_endpoint_uri, token_endpoint_uri, app_uri,
+  client_id, client_secret, scope, login_ui = oauth_login_button,
+  logout_ui = oauth_logout_button) {
+
+  list(
+    oauth_endpoint_uri = oauth_endpoint_uri,
+    token_endpoint_uri = token_endpoint_uri,
+    app_uri = app_uri,
+    client_id = client_id,
+    client_secret = client_secret,
+    scope = scope,
+    login_ui = login_ui,
+    logout_ui = logout_ui
+  )
+}
+
+# Server module for initializing oauth
+oauth_login <- function(input, output, session, oauth_config) {
+
+  force(oauth_config)
+
+  token <- reactiveVal(NULL)
+
+  # TODO: make parsing robust (escaping)
+  cookie <- session$request$HTTP_COOKIE
+  if (!is.null(cookie)) {
+    m <- regmatches(cookie, regexec("shinyoauthaccesstoken=([^;]+)", cookie, perl = TRUE))[[1]]
+    if (length(m) > 0) {
+      token(m[[2]])
+    }
+  }
+
+  redirect_uri <- sub("/?$", "/oauth_callback", oauth_config$app_uri)
+
+  state <- store_oauth_request_state(token,
+    redirect_uri,
+    oauth_config$token_endpoint_uri,
+    oauth_config$client_id,
+    oauth_config$client_secret,
+    session)
+
+  # Prepend the worker ID onto the state parameter. Servers like
+  # Connect and SSP use the `w` query string parameter to determine
+  # what R process needs to handle a request. But we can't add a
+  # `w` parameter to our callback URI; the only part of the path or
+  # query string we can safely influence is `state`.
+  #
+  # When this state parameter is read by our callback handler, then
+  # this worker id information will be unpacked, and the browser
+  # will redirect back to the same page but with `w` extracted from
+  # state and added as its own standalone query string param.
+  state <- paste0(
+    "_w_", shiny:::workerId(), "_",
+    state
+  )
+
+  output$container <- renderUI({
+    if (is.null(token())) {
+      # login button
+      url <- make_authorization_url(oauth_config, redirect_uri, state, session)
+
+      oauth_config$login_ui(url)
+    } else {
+      oauth_config$logout_ui(session$ns("btn_logout"))
+    }
+  })
+
+  observeEvent(input$btn_logout, {
+    oauth_do_logout(token)
+  })
+
+  return(token)
+}
+
+oauth_request_state <- fastmap::fastmap()
+
+store_oauth_request_state <- function(rv, redirect_uri, token_endpoint_uri, client_id, client_secret, session = getDefaultReactiveDomain()) {
+  state <- shiny:::createUniqueId(16)
+  oauth_request_state$set(state, list(
+    rv = rv,
+    redirect_uri = redirect_uri,
+    token_endpoint_uri = token_endpoint_uri,
+    client_id = client_id,
+    client_secret = client_secret
+  ))
+
+  # In case the session ends, clean out the state so we don't leak memory
+  shiny::onSessionEnded(function() {
+    oauth_request_state$remove(state)
+  })
+
+  state
+}
+
+
+make_authorization_url <- function(oauth_config, redirect_uri, state, session = getDefaultReactiveDomain()) {
+  # TODO: Implement for real
+  #
+  # The req object is a Rook request. This is just an environment object that
+  # gives you access to the request URL, HTTP headers, etc. The documentation
+  # for this object is here:
+  # https://github.com/jeffreyhorner/Rook#the-environment
+  url_template <- "%s?client_id=%s&redirect_uri=%s&response_type=code&state=%s&access_type=offline&include_granted_scopes=true&scope=%s"
+  auth_url <- sprintf(url_template,
+    oauth_config$oauth_endpoint_uri,
+    utils::URLencode(oauth_config$client_id, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(redirect_uri, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(state, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(oauth_config$scope, reserved = TRUE, repeated = TRUE)
+  )
+
+  auth_url
+}
+
+# This is the Rook handler that is invoked when the browser returns
+# from authenticating with the OAuth provider. Based on the `code`
+# and `state` in the query string, we'll look up oauth_request_state
+# and retrieve the oauth token.
+oauth_callback_handler <- function(req) {
+  if (!identical(req$REQUEST_METHOD, 'GET'))
+    return(NULL)
+
+  qs_info <- parseQueryString(req$QUERY_STRING)
+  err <- qs_info$error
+  code <- qs_info$code
+
+  # TODO: state should be signed/verified
+  state <- qs_info$state
+  if (!is.null(err)) {
+    # TODO: Report error to user
+    message(jsonlite::toJSON(qs_info, pretty = TRUE, auto_unbox = TRUE))
+    return(list(
+      status = 500L,
+      headers = list("Content-Type" = "text/plain"),
+      body = "Authorization failure"
+    ))
+  } else if (!is.null(code) && !is.null(state)) {
+
+    # See if state has worker information in it that we need to extract.
+    # If so, we need to redirect the browser with a `w=` parameter, so
+    # that server environments can ensure we end up at the right R
+    # process
+
+    if (is.null(qs_info$w)) {
+      m <- regexec("^_w_([a-fA-F0-9]*)_([a-fA-f0-9]+)$", state)
+      m <- regmatches(qs_info$state, m)[[1]]
+      if (length(m) > 0) {
+        worker_id <- m[[2]]
+        new_state <- m[[3]]
+        new_qs <- sub(
+          "([&?])state=.*?(&|$)",
+          sprintf("\\1state=%s&w=%s\\2",
+            utils::URLencode(new_state, reserved = TRUE, repeated = TRUE),
+            utils::URLencode(worker_id, reserved = TRUE, repeated = TRUE)
+          ),
+          req$QUERY_STRING
+        )
+        return(list(
+          status = 307L,
+          headers = list(
+            "Content-Type" = "text/plain",
+            "Location" = new_qs
+          ),
+          body = ""
+        ))
+      }
+    }
+
+    req_info <- oauth_request_state$get(state)
+    if (is.null(req_info)) {
+      # TODO: Report error to user
+      stop("OAuth authentication request not recognized")
+    }
+
+    redirect_uri <- req_info$redirect_uri
+    token_endpoint_uri <- req_info$token_endpoint_uri
+    client_id <- req_info$client_id
+    client_secret <- req_info$client_secret
+    rv <- req_info$rv
+
+    resp <- httr::POST(token_endpoint_uri,
+      body = list(
+        client_id = client_id,
+        code = code,
+        redirect_uri = redirect_uri,
+        grant_type = "authorization_code",
+        client_secret = client_secret
+      )
+    )
+    respObj <- httr::content(resp, as = "parsed")
+
+    rv(respObj$access_token)
+
+    return(list(
+      status = 200L,
+      headers = list(
+        "Content-Type" = "text/html",
+        # TODO: encrypt
+        # TODO: expiration
+        # TODO: secure (optionally)
+        # TODO: escaping
+        # TODO: path/samesite
+        "Set-Cookie" = sprintf("shinyoauthaccesstoken=%s; HttpOnly; Path=/", respObj$access_token)
+      ),
+      body = as.character(
+        tags$html(
+          HTML("<head><script>window.close();</script></head>"),
+          tags$body(
+            "You can close this window now"
+          )
+        )
+      )
+    ))
+  } else {
+    # TODO: Report malformed request
+  }
+}
+
+addRouteHandler("/oauth_callback", oauth_callback_handler)
+
+
+clear_cookie_xsrf <- fastmap::fastmap()
+
+oauth_clear_cookie_handler <- function(req) {
+  if (req$REQUEST_METHOD != "POST") {
+    return(NULL)
+  }
+
+  xsrf_token <- req$rook.input$read_lines(1)
+  if (is.null(clear_cookie_xsrf$get(xsrf_token))) {
+    return(list(
+      status = 403L,
+      headers = list(
+        "Content-Type" = "text/plain"
+      ),
+      body = "Unrecognized XSRF token"
+    ))
+  }
+  clear_cookie_xsrf$remove(xsrf_token)
+
+  return(list(
+    status = 200L,
+    headers = list(
+      "Content-Type" = "text/plain",
+      "Set-Cookie" = "shinyoauthaccesstoken=; HttpOnly; Path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT"
+    ),
+    body = ""
+  ))
+}
+
+addRouteHandler("/oauth_clear_cookie", oauth_clear_cookie_handler)
+
+clear_cookie_custom_handler <- tags$script(
+  "
+    Shiny.addCustomMessageHandler('oauth-clear-cookie-handler', function(msg) {
+      var req = new XMLHttpRequest();
+      req.open('POST', 'oauth_clear_cookie');
+      req.setRequestHeader('Content-Type', 'text/plain');
+      req.send(msg.xsrf_token);
+    });
+  "
+)