R/oauth-token.r

In httr: Tools for Working with URLs and HTTP

#' OAuth token objects.
#'
#' These objects represent the complete set of data needed for OAuth access:
#' an app, an endpoint, cached credentials and parameters. They should be
#' created through their constructor functions [oauth1.0_token()]
#' and [oauth2.0_token()].
#'
#' @section Methods:
#' * `cache()`: caches token to disk
#' * `sign(method, url)`: returns list of url and config
#' * `refresh()`: refresh access token (if possible)
#' * `validate()`: TRUE if the token is still valid, FALSE otherwise
#'
#' @section Caching:
#' OAuth tokens are cached on disk in a file called `.httr-oauth`
#' saved in the current working directory.  Caching is enabled if:
#'
#' * The session is interactive, and the user agrees to it, OR
#' * The `.httr-oauth` file is already present, OR
#' * `getOption("httr_oauth_cache")` is `TRUE`
#'
#' You can suppress caching by setting the `httr_oauth_cache` option to
#' `FALSE`.
#'
#' Tokens are cached based on their endpoint and parameters.
#'
#' The cache file should not be included in source code control or R packages
#' (because it contains private information), so httr will automatically add
#' the appropriate entries to `.gitignore` and `.Rbuildignore` if needed.
#'
#' @docType class
#' @keywords internal
#' @format An R6 class object.
#' @importFrom R6 R6Class
#' @export
#' @name Token-class
Token <- R6::R6Class("Token", list(
  endpoint = NULL,
  app = NULL,
  credentials = NULL,
  params = NULL,
  cache_path = FALSE,
  private_key = NULL,

  initialize = function(app, endpoint, params = list(), credentials = NULL,
                        private_key = NULL,
                        cache_path = getOption("httr_oauth_cache")) {
    stopifnot(
      is.oauth_endpoint(endpoint) || !is.null(credentials),
      is.oauth_app(app),
      is.list(params)
    )

    self$app <- app
    self$endpoint <- endpoint
    self$params <- params
    self$cache_path <- use_cache(cache_path)
    self$private_key <- private_key

    if (!is.null(credentials)) {
      # Use credentials created elsewhere - usually for tests
      self$credentials <- credentials
      return(self)
    }

    # Are credentials cache already?
    if (self$load_from_cache()) {
      self
    } else {
      self$init_credentials()
      self$cache()
    }
  },

  print = function(...) {
    cat("<Token>\n", sep = "")
    print(self$endpoint)
    print(self$app)
    cat("<credentials> ", paste0(names(self$credentials), collapse = ", "), "\n",
      sep = ""
    )
    cat("---\n")
  },
  cache = function(path = self$cache_path) {
    cache_token(self, path)
    self
  },
  load_from_cache = function() {
    if (is.null(self$cache_path)) return(FALSE)

    cached <- fetch_cached_token(self$hash(), self$cache_path)
    if (is.null(cached)) return(FALSE)

    self$endpoint <- cached$endpoint
    self$app <- cached$app
    self$credentials <- cached$credentials
    self$params <- cached$params
    TRUE
  },
  hash = function() {
    # endpoint = which site
    # app = client identification
    # params = scope
    msg <- serialize(
      list(self$endpoint, self$app, normalize_scopes(self$params$scope)),
      NULL
    )

    # for compatibility with digest::digest()
    paste(openssl::md5(msg[-(1:14)]), collapse = "")
  },
  sign = function() {
    stop("Must be implemented by subclass", call. = FALSE)
  },
  refresh = function() {
    stop("Must be implemented by subclass", call. = FALSE)
  },
  init_credentials = function() {
    stop("Must be implemented by subclass", call. = FALSE)
  }
))

#' Generate an oauth1.0 token.
#'
#' This is the final object in the OAuth dance - it encapsulates the app,
#' the endpoint, other parameters and the received credentials.
#'
#' See [Token()] for full details about the token object, and the
#' caching policies used to store credentials across sessions.
#'
#' @inheritParams init_oauth1.0
#' @param as_header If `TRUE`, the default, sends oauth in header.
#'   If `FALSE`, adds as parameter to url.
#' @param cache A logical value or a string. `TRUE` means to cache
#'   using the default cache file `.httr-oauth`, `FALSE` means
#'   don't cache, and `NA` means to guess using some sensible heuristics.
#'   A string means use the specified path as the cache file.
#' @return A `Token1.0` reference class (RC) object.
#' @family OAuth
#' @export
oauth1.0_token <- function(endpoint, app, permission = NULL,
                           as_header = TRUE,
                           private_key = NULL,
                           cache = getOption("httr_oauth_cache")) {
  params <- list(
    permission = permission,
    as_header = as_header
  )

  Token1.0$new(
    app = app,
    endpoint = endpoint,
    params = params,
    private_key = private_key,
    cache_path = cache
  )
}

#' @export
#' @rdname Token-class
Token1.0 <- R6::R6Class("Token1.0", inherit = Token, list(
  init_credentials = function(force = FALSE) {
    self$credentials <- init_oauth1.0(
      self$endpoint, self$app,
      permission = self$params$permission,
      private_key = self$private_key
    )
  },
  can_refresh = function() {
    FALSE
  },
  refresh = function() {
    stop("Not implemented")
  },
  sign = function(method, url) {
    oauth <- oauth_signature(
      url, method, self$app, self$credentials$oauth_token,
      self$credentials$oauth_token_secret, self$private_key
    )
    if (isTRUE(self$params$as_header)) {
      c(request(url = url), oauth_header(oauth))
    } else {
      url <- parse_url(url)
      url$query <- c(url$query, oauth)
      request(url = build_url(url))
    }
  }
))

#' Generate an oauth2.0 token.
#'
#' This is the final object in the OAuth dance - it encapsulates the app,
#' the endpoint, other parameters and the received credentials. It is a
#' reference class so that it can be seamlessly updated (e.g. using
#' `$refresh()`) when access expires.
#'
#' See [Token()] for full details about the token object, and the
#' caching policies used to store credentials across sessions.
#'
#' @inheritParams init_oauth2.0
#' @param as_header If `TRUE`, the default, configures the token to add
#'   itself to the bearer header of subsequent requests. If `FALSE`,
#'   configures the token to add itself as a url parameter of subsequent
#'   requests.
#' @param credentials Advanced use only: allows you to completely customise
#'   token generation.
#' @inheritParams oauth1.0_token
#' @return A `Token2.0` reference class (RC) object.
#' @family OAuth
#' @export
oauth2.0_token <- function(endpoint, app, scope = NULL, user_params = NULL,
                           type = NULL,
                           use_oob = getOption("httr_oob_default"),
                           oob_value = NULL,
                           as_header = TRUE,
                           use_basic_auth = FALSE,
                           cache = getOption("httr_oauth_cache"),
                           config_init = list(),
                           client_credentials = FALSE,
                           credentials = NULL,
                           query_authorize_extra = list()) {
  params <- list(
    scope = scope,
    user_params = user_params,
    type = type,
    use_oob = use_oob,
    oob_value = oob_value,
    as_header = as_header,
    use_basic_auth = use_basic_auth,
    config_init = config_init,
    client_credentials = client_credentials,
    query_authorize_extra = query_authorize_extra
  )

  Token2.0$new(
    app = app,
    endpoint = endpoint,
    params = params,
    credentials = credentials,
    cache_path = if (is.null(credentials)) cache else FALSE
  )
}

#' @export
#' @rdname Token-class
Token2.0 <- R6::R6Class("Token2.0", inherit = Token, list(
  init_credentials = function() {
    self$credentials <- init_oauth2.0(self$endpoint, self$app,
      scope = self$params$scope, user_params = self$params$user_params,
      type = self$params$type, use_oob = self$params$use_oob,
      oob_value = self$params$oob_value,
      use_basic_auth = self$params$use_basic_auth,
      config_init = self$params$config_init,
      client_credentials = self$params$client_credentials,
      query_authorize_extra = self$params$query_authorize_extra
    )
  },
  can_refresh = function() {
    !is.null(self$credentials$refresh_token)
  },
  refresh = function() {
    cred <- refresh_oauth2.0(
      self$endpoint, self$app,
      self$credentials, self$params$user_params, self$params$use_basic_auth
    )
    if (is.null(cred)) {
      remove_cached_token(self)
    } else {
      self$credentials <- cred
      self$cache()
    }
    self
  },
  sign = function(method, url) {
    if (self$params$as_header) {
      request(url = url, headers = c(
        Authorization = paste("Bearer", self$credentials$access_token)
      ))
    } else {
      url <- parse_url(url)
      url$query$access_token <- self$credentials$access_token
      request(url = build_url(url))
    }
  },
  validate = function() {
    validate_oauth2.0(self$endpoint, self$credentials)
  },
  revoke = function() {
    revoke_oauth2.0(self$endpoint, self$credentials)
  }
))


#' Generate OAuth token for service accounts.
#'
#' Service accounts provide a way of using OAuth2 without user intervention.
#' They instead assume that the server has access to a private key used
#' to sign requests. The OAuth app is not needed for service accounts:
#' that information is embedded in the account itself.
#'
#' @inheritParams oauth2.0_token
#' @inheritParams jwt_signature
#' @param secrets Secrets loaded from JSON file, downloaded from console.
#' @family OAuth
#' @export
#' @examples
#' \dontrun{
#' endpoint <- oauth_endpoints("google")
#' secrets <- jsonlite::fromJSON("~/Desktop/httrtest-45693cbfac92.json")
#' scope <- "https://www.googleapis.com/auth/bigquery.readonly"
#'
#' token <- oauth_service_token(endpoint, secrets, scope)
#' }
oauth_service_token <- function(endpoint, secrets, scope = NULL, sub = NULL) {
  if (!is.oauth_endpoint(endpoint)) {
    stop("`endpoint` must be an OAuth endpoint", call. = FALSE)
  }
  if (!is.list(secrets)) {
    stop("`secrets` must be a list.", call. = FALSE)
  }

  scope <- check_scope(scope)

  TokenServiceAccount$new(
    endpoint = endpoint,
    secrets = secrets,
    params = list(scope = scope, sub = sub)
  )
}

#' @export
#' @rdname Token-class
TokenServiceAccount <- R6::R6Class("TokenServiceAccount", inherit = Token2.0, list(
  secrets = NULL,
  initialize = function(endpoint, secrets, params) {
    self$endpoint <- endpoint
    self$secrets <- secrets
    self$params <- params

    self$refresh()
  },
  can_refresh = function() {
    TRUE
  },
  refresh = function() {
    self$credentials <- init_oauth_service_account(
      self$secrets,
      scope = self$params$scope,
      sub = self$params$sub
    )
    self
  },
  sign = function(method, url) {
    config <- add_headers(
      Authorization = paste("Bearer", self$credentials$access_token)
    )
    request_build(method = method, url = url, config)
  },

  # Never cache
  cache = function(path) self,
  load_from_cache = function() self
))

normalize_scopes <- function(x) {
  stats::setNames(sort(unique(x)), NULL)
}