R/auth.r

In atrrr: Wrapper for the 'AT' Protocol Behind 'Bluesky'

#' Authenticate for the  API
#'
#' @description Run authentication for a network using the AT protocol (e.g.,
#'   ['Blue Sky'](https://bsky.app/)) and save the token permanently.
#'
#' @param user Your user handle (e.g, benguinaudeau.bsky.social).
#' @param password Your app password (usually created on
#'   https://bsky.app/settings/app-passwords).
#' @param domain For now https://bsky.app/, but could change in the future.
#' @param overwrite If TRUE, overwrites old token without asking for
#'   confirmation.
#' @param token (Stale) token object. Usually you don't need to use this. But if
#'   you manage your own tokens and they get stale, you can use this parameter
#'   and request a fresh token.
#'
#' @inheritParams search_user
#' @returns An authentication token (invisible)
#'
#' @details After requesting the token, it is saved in the location returned by
#'   `file.path(tools::R_user_dir("atrrr", "cache"), Sys.getenv("BSKY_TOKEN",
#'   unset = "token.rds"))`. If you have multiple tokens, you can use
#'   `Sys.setenv(BSKY_TOKEN = "filename.rds")` to save/load the token with a
#'   different name.
#'
#' @examples
#' \dontrun{
#' # request a token
#' auth() # this will guide you through all steps
#'
#' # the token is stored in the location returned by this command
#' file.path(tools::R_user_dir("atrrr", "cache"),
#'           Sys.getenv("BSKY_TOKEN", unset = "token.rds"))
#'
#' # to use a different than the default file name for the token, set BSKY_TOKEN
#' Sys.setenv(BSKY_TOKEN = "identity-2.rds")
#'
#' # now either rename your token file or request a new token
#' auth()
#'
#' # the cache now contains two tokens
#' list.files(tools::R_user_dir("atrrr", "cache"))
#'
#' # functions that interact with the API also take a .token argument with the
#' # path. For example:
#' tok_path <- file.path(tools::R_user_dir("atrrr", "cache"), "identity-2.rds")
#' get_skeets_authored_by(actor = "benguinaudeau.bsky.social", parse = TRUE,
#'                        .token = tok_path)
#' }
#'
#' @export
auth <- function(
  user,
  password,
  domain = "https://bsky.app/",
  verbose = TRUE,
  overwrite = FALSE,
  token = NULL
) {
  if (is.null(token)) {
    url <- list(
      scheme = "https",
      hostname = httr2::url_parse(domain)$hostname,
      path = "/settings/app-passwords"
    ) |>
      structure(class = "httr2_url") |>
      httr2::url_build()

    if (missing(user)) {
      rlang::check_installed("askpass")
      user <- askpass::askpass(
        "Please enter your username (e.g., \"jbgruber.bsky.social\")"
      )
    }

    if (missing(password) || is.null(password)) {
      if (interactive()) {
        if (verbosity(verbose)) {
          cli::cli_alert_info(
            "Navigate to {.url {url}} and create a new app password"
          )
        }
        utils::browseURL(url)
        password <- askpass::askpass("Please enter your app password")
      } else {
        cli::cli_abort("You need to run {.fn auth} in an interactive session")
      }
    }

    if (!is.null(user) && !is.null(password)) {
      pds <- tryCatch(
        resolve_pds(user),
        error = function(e) "https://bsky.social"
      )
      token <- req_token(user, password, pds = pds)
      token$pds <- pds
    } else {
      cli::cli_abort("You need to supply username and password.")
    }
  } else {
    if (!methods::is(token, "bsky_token")) {
      cli::cli_abort("token needs to be an object of class {.emph bsky_token}")
    }
    token <- refresh_token(token)
  }

  token$domain <- domain
  token$accessJwt <- token$accessJwt
  token$refreshJwt <- token$refreshJwt
  token$valid_until <- Sys.time() + 2 * 60 * 60

  class(token) <- "bsky_token"

  f <- Sys.getenv("BSKY_TOKEN", unset = "token.rds")
  p <- tools::R_user_dir("atrrr", "cache")
  dir.create(p, showWarnings = FALSE, recursive = TRUE)

  # store in cache
  rlang::env_poke(env = the, nm = "bsky_token", value = token, create = TRUE)

  sel <- TRUE
  if (file.exists(file.path(p, f)) && !overwrite) {
    sel <- utils::askYesNo(
      "A token already exists on disk. Do you want to overwrite it?",
      default = FALSE
    )
  }

  if (isTRUE(sel)) {
    httr2::secret_write_rds(
      x = token,
      path = file.path(p, f),
      key = I(rlang::hash("musksucks"))
    )
    if (verbosity(verbose)) {
      cli::cli_alert_success("Succesfully authenticated!")
    }
    invisible(token)
  }
}


req_token <- function(user, password, pds = "https://bsky.social") {
  # https://atproto.com/specs/xrpc#authentication
  httr2::request(pds) |>
    httr2::req_url_path("/xrpc/com.atproto.server.createSession") |>
    httr2::req_method("POST") |>
    httr2::req_body_json(list(
      identifier = user,
      password = password
    )) |>
    httr2::req_error(body = error_parse) |>
    httr2::req_perform() |>
    httr2::resp_body_json()
}


get_token <- function() {
  f <- file.path(
    tools::R_user_dir("atrrr", "cache"),
    Sys.getenv("BSKY_TOKEN", unset = "token.rds")
  )

  if (rlang::env_has(the, nms = "bsky_token")) {
    token <- rlang::env_get(the, nm = "bsky_token", I(rlang::hash("musksucks")))
  } else if (file.exists(f)) {
    token <- read_token(f)
  } else if (!is.null(getOption("httr2_mock", NULL))) {
    token <- list(
      valid_until = Sys.time() + 10^7,
      accessJwt = "testing",
      handle = "testing"
    )
  } else {
    token <- auth()
  }

  if (token$valid_until < Sys.time()) {
    token <- auth(
      token = token,
      verbose = FALSE,
      overwrite = TRUE
    )
  }

  invisible(token)
}


refresh_token <- function(token) {
  pds <- token$pds %||% "https://bsky.social"
  new_tok <- httr2::request(pds) |>
    httr2::req_url_path("/xrpc/com.atproto.server.refreshSession") |>
    httr2::req_method("POST") |>
    httr2::req_auth_bearer_token(token = token$refreshJwt) |>
    httr2::req_error(
      is_error = function(resp) {
        httr2::resp_status(resp) >= 400 &
          !grepl(
            "Token has been revoked",
            httr2::resp_body_string(resp),
            fixed = TRUE
          )
      },
      body = error_parse
    ) |>
    httr2::req_perform() |>
    httr2::resp_body_json()

  if (purrr::pluck_exists(new_tok, "error")) {
    new_tok <- req_token(token$handle, token$password, pds = pds)
  }

  new_tok$pds <- pds
  new_tok
}


#' @title Print token
#'
#' @description Print a AT token
#'
#' @param x An object of class \code{bsky_token}
#' @param ... not used.
#'
#' @return No return value, called to print the token to screen
#' @export
print.bsky_token <- function(x, ...) {
  cli::cli_h1("Blue Sky token")
  cli::cat_bullet(
    glue::glue("User: {x$handle}"),
    background_col = "#0560FF",
    col = "#F3F9FF"
  )
  cli::cat_bullet(
    glue::glue("PDS: {x$pds %||% 'https://bsky.social'}"),
    background_col = "#0560FF",
    col = "#F3F9FF"
  )
  cli::cat_bullet(
    glue::glue("Domain: {x$domain}"),
    background_col = "#0560FF",
    col = "#F3F9FF"
  )
  cli::cat_bullet(
    glue::glue("Valid until: {x$valid_until}"),
    background_col = "#0560FF",
    col = "#F3F9FF"
  )
}


read_token <- function(f) {
  httr2::secret_read_rds(f, I(rlang::hash("musksucks")))
}