R/accounts.R

Defines functions accountLabel registerAccount removeAccount hasAccount accountInfo findShinyAppsAccountId setAccountInfo getAuthedUser waitForAuthedUser generateToken getAuthToken getAuthTokenAndUser connectUser connectApiUser accounts

Documented in accountInfo accounts connectApiUser connectUser removeAccount setAccountInfo

#' Account Management Functions
#'
#' Functions to enumerate and remove accounts on the local system. Prior to
#' deploying applications you need to register your account on the local system.
#'
#' You register an account using the [setAccountInfo()] function (for
#' ShinyApps) or [connectUser()] function (for other servers). You can
#' subsequently remove the account using the `removeAccount` function.
#'
#' The `accounts` and `accountInfo` functions are provided for viewing
#' previously registered accounts.
#'
#' @param name Name of account
#' @param server Name of the server on which the account is registered
#'   (optional; see [servers()])
#'
#' @return `accounts` returns a data frame with the names of all accounts
#' registered on the system and the servers on which they reside.
#' `accountInfo` returns a list with account details.
#'
#' @rdname accounts
#' @export
accounts <- function(server = NULL) {
  configPaths <- accountConfigFiles(server)

  names <- file_path_sans_ext(basename(configPaths))

  servers <- basename(dirname(configPaths))
  servers[servers == "."] <- "shinyapps.io"

  data.frame(name = names, server = servers, stringsAsFactors = FALSE)
}

#' Register account on Posit Connect
#
#' @description
#' `connectUser()` and `connectApiUser()` connect your Posit Connect account to
#' the rsconnect package so that it can deploy and manage applications on
#' your behalf.
#'
#' `connectUser()` is the easiest place to start because it allows you to
#' authenticate in-browser to your Posit Connect server. `connectApiUser()` is
#' appropriate for non-interactive settings; you'll need to copy-and-paste the
#' API key from your account settings.
#'
#' @param account A name for the account to connect.
#' @param server The server to connect to.
#' @param launch.browser If true, the system's default web browser will be
#'   launched automatically after the app is started. Defaults to `TRUE` in
#'   interactive sessions only. If a function is passed, it will be called
#'   after the app is started, with the app URL as a parameter.
#' @param apiKey The API key used to authenticate the user
#' @param quiet Whether or not to show messages and prompts while connecting the
#'   account.
#' @family Account functions
#' @export
connectApiUser <- function(account = NULL, server = NULL, apiKey, quiet = FALSE) {
  server <- findServer(server)
  user <- getAuthedUser(server, apiKey = apiKey)

  registerAccount(
    serverName = server,
    accountName = account %||% user$username,
    accountId = user$id,
    apiKey = apiKey
  )

  if (!quiet) {
    accountLabel <- accountLabel(user$username, server)
    cli::cli_alert_success("Registered account for {accountLabel}")
  }
  invisible()
}

#' @rdname connectApiUser
#' @export
connectUser <- function(account = NULL,
                        server = NULL,
                        quiet = FALSE,
                        launch.browser = getOption("rsconnect.launch.browser", interactive())) {
  server <- findServer(server)
  resp <- getAuthTokenAndUser(server, launch.browser)

  registerAccount(
    serverName = server,
    accountName = account %||% resp$user$username,
    accountId = resp$user$id,
    token = resp$token$token,
    private_key = resp$token$private_key
  )

  if (!quiet) {
    accountLabel <- accountLabel(resp$user$username, server)
    cli::cli_alert_success("Registered account for {accountLabel}")
  }
  invisible()
}

getAuthTokenAndUser <- function(server, launch.browser = TRUE) {
  token <- getAuthToken(server)

  if (isTRUE(launch.browser))
    utils::browseURL(token$claim_url)
  else if (is.function(launch.browser))
    launch.browser(token$claim_url)

  if (isFALSE(launch.browser)) {
    cli::cli_alert_warning("Open {.url {token$claim_url}} to authenticate")
  } else {
    cli::cli_alert_info("A browser window should open to complete authentication")
    cli::cli_alert_warning("If it doesn't open, please go to {.url {token$claim_url}}")
  }

  user <- waitForAuthedUser(
    server,
    token = token$token,
    private_key = token$private_key
  )

  list(
    token = token,
    user = user
  )
}

# Used by the IDE
getAuthToken <- function(server, userId = 0) {
  token <- generateToken()

  # Send public key to server, and generate URL where the token can be claimed
  account <- list(server = server)
  client <- clientForAccount(account)
  response <- client$addToken(list(
    token = token$token,
    public_key = token$public_key,
    user_id = 0L
  ))

  list(
    token = token$token,
    private_key = secret(token$private_key),
    claim_url = response$token_claim_url
  )
}

# generateToken generates a token for signing requests sent to the Posit
# Connect service. The token's ID and public key are sent to the server, and
# the private key is saved locally.
generateToken <- function() {
  key <- openssl::rsa_keygen(2048L)
  priv.der <- openssl::write_der(key)
  pub.der <- openssl::write_der(key$pubkey)
  tokenId <- paste(c("T", openssl::rand_bytes(16)), collapse = "")

  list(
    token = tokenId,
    public_key = openssl::base64_encode(pub.der),
    private_key = openssl::base64_encode(priv.der)
  )
}

waitForAuthedUser <- function(server,
                              token = NULL,
                              private_key = NULL,
                              apiKey = NULL) {
  # keep trying to authenticate until we're successful; server returns
  # 500 "Token is unclaimed error" while waiting for interactive auth to complete
  cli::cli_progress_bar(format = "{cli::pb_spin} Waiting for authentication...")

  repeat {
    for (i in 1:10) {
      Sys.sleep(0.1)
      cli::cli_progress_update()
    }
    user <- tryCatch(
      getAuthedUser(
        server,
        token = token,
        private_key = private_key,
        apiKey = apiKey
      ),
      rsconnect_http_500 = function(err) NULL
    )
    if (!is.null(user)) {
      cli::cli_progress_done()
      break
    }
  }

  user
}

getAuthedUser <- function(server,
                          token = NULL,
                          private_key = NULL,
                          apiKey = NULL) {
  if (!xor(is.null(token) && is.null(private_key), is.null(apiKey))) {
    cli::cli_abort("Must supply either {.arg token} + {private_key} or {.arg apiKey}")
  }

  account <- list(
    server = server,
    apiKey = apiKey,
    token = token,
    private_key = private_key
  )
  client <- clientForAccount(account)
  client$currentUser()
}

#' Register account on shinyapps.io or posit.cloud
#'
#' Configure a ShinyApps or Posit Cloud account for publishing from this system.
#'
#' @param name Name of account to save or remove
#' @param token User token for the account
#' @param secret User secret for the account
#' @param server Server to associate account with.
#'
#' @examples
#' \dontrun{
#'
#' # register an account
#' setAccountInfo("user", "token", "secret")
#'
#' # remove the same account
#' removeAccount("user")
#' }
#'
#' @family Account functions
#' @export
setAccountInfo <- function(name, token, secret, server = "shinyapps.io") {
  check_string(name)
  check_string(token)
  check_string(secret)
  check_string(server)

  accountId <- findShinyAppsAccountId(name, token, secret, server)

  registerAccount(
    serverName = server,
    accountName = name,
    accountId = accountId,
    token = token,
    secret = secret
  )
  invisible()
}

# A user can have multiple accounts, so iterate over all accounts looking
# for one with the specified name
findShinyAppsAccountId <- function(name,
                                   token,
                                   secret,
                                   server,
                                   error_call = caller_env()) {
  if (secret == "<SECRET>") {
    cli::cli_abort(
      c(
        "You've copied and pasted the wrong thing.",
        i = "Either click 'Show secret' or 'Copy to clipboard'."
      ),
      call = error_call
    )
  }

  account <- list(token = token, secret = secret, server = server)
  client <- clientForAccount(account)

  userId <- client$currentUser()$id

  accountId <- NULL
  accounts <- client$accountsForUser(userId)
  for (account in accounts) {
    if (identical(account$name, name)) {
      return(account$id)
    }
  }
  cli::cli_abort("Unable to determine {.arg accountId} for account {.str {name}}")
}

#' @rdname accounts
#' @family Account functions
#' @export
accountInfo <- function(name = NULL, server = NULL) {
  fullAccount <- findAccount(name, server)
  configFile <- accountConfigFile(fullAccount$name, fullAccount$server)

  accountDcf <- read.dcf(configFile, all = TRUE)
  info <- as.list(accountDcf)
  # remove all whitespace from private key
  if (!is.null(info$private_key)) {
    info$private_key <- gsub("[[:space:]]", "", info$private_key)
  }

  # Hide credentials
  info$private_key <- secret(info$private_key)
  info$secret <- secret(info$secret)
  info$apiKey <- secret(info$apiKey)

  info
}

hasAccount <- function(name, server) {
  file.exists(accountConfigFile(name, server))
}

#' @rdname accounts
#' @export
removeAccount <- function(name = NULL, server = NULL) {
  fullAccount <- findAccount(name, server)

  configFile <- accountConfigFile(fullAccount$name, fullAccount$server)
  file.remove(configFile)

  invisible(NULL)
}

registerAccount <- function(serverName,
                            accountName,
                            accountId,
                            token = NULL,
                            secret = NULL,
                            private_key = NULL,
                            apiKey = NULL) {

  check_string(serverName)
  check_string(accountName)
  if (!is.null(secret)) {
    secret <- as.character(secret)
  }

  fields <- list(
    name = accountName,
    server = serverName,
    accountId = accountId,
    token = token,
    secret = secret,
    private_key = private_key,
    apiKey = apiKey
  )

  path <- accountConfigFile(accountName, serverName)
  dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
  write.dcf(compact(fields), path, width = 100)

  # set restrictive permissions on it if possible
  if (identical(.Platform$OS.type, "unix"))
    Sys.chmod(path, mode = "0600")

  path
}

accountLabel <- function(account, server) {
  paste0("server: ", server, " / username: ", account)
}

Try the rsconnect package in your browser

Any scripts or data that you put into this service are public.

rsconnect documentation built on Oct. 4, 2023, 5:07 p.m.