auth into polite closes #10

NAMESPACE

@@ -1,11 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
 export("%>%")
+export(best_pool)
 export(can_api)
 export(can_pool)
+export(could_pool)
 export(get_cr_mailto)
 export(get_cr_token)
 export(is_email_address)
+export(pools)
 export(req_cr)
 export(resp_cr_pool)
 export(was_pool)

R/api.R

@@ -1,27 +1,45 @@
 #' Use the [Crossref REST API](https://api.crossref.org/swagger-ui/index.html)
 #'
+#' @details
+#' Will always try to authenticate into the most performant API pool possible,
+#' but gracefully downgrades to less performant pools,
+#' when `mailto` or `token` cannot be found.
+#' See [req_auth_pool()] for details.
+#'
+#' @inheritParams req_auth_pool
 #' @family api functions
 #' @export
-req_cr <- function() {
-  httr2::request("https://api.crossref.org/") %>%
-    req_user_agent_cr()
+req_cr <- function(mailto = get_cr_mailto()) {
+  httr2::request("https://api.crossref.org/works") %>%
+    req_user_agent_cr(mailto = NULL) %>%
+    # below overwrites above ua, duplication is necessary 
+    # because only req_auth_pool() gives feedback
+    req_auth_pool(mailto = mailto)
 }
 
 #' Set a user agent
 #'
-#' To set a `mailto`, see [polite()].
-#'
+#' @param mailto a character scalar giving a valid email address.
 #' @inheritParams httr2::req_user_agent
-#' @noRd
-req_user_agent_cr <- function(req) {
-  httr2::req_user_agent(
-    req = req,
-    string = paste0(
+#' @keywords internal
+req_user_agent_cr <- function(req, mailto = NULL) {
+  if (is.null(mailto)) {
+    ua <- paste0(
       "crlite/",
       utils::packageVersion("crlite"),
       "(https://github.com/subugoe/crlite/)"
     )
-  )
+  } else {
+    ua <- paste0(
+      "crlite/",
+      utils::packageVersion("crlite"),
+      "(https://github.com/subugoe/crlite/; ",
+      "mailto:",
+      mailto,
+      ")"
+    )
+  }
+  httr2::req_user_agent(req = req, string = ua)
 }
 
 #' Test whether API can be reached

R/pools.R

@@ -1,46 +1,108 @@
 # testing ====
-#' Diagnosing API pools
-#' @name pools
+#' Accessing different Crossref API pools
+#'
+#' In increasing order of performance: `r pools()`.
+#'
 #' @family api pool access functions
-NULL
+#' @export
+pools <- function() c("public", "polite", "plus")
+
+#' @describeIn pools Try to authenticate into the highest performing pool
+#' 
+#' Function checks whether a higher performance pool is possible,
+#' using [could_pool()].
+#' Only when that test passes, is the request authenticated.
+#' The function thus gracefully recovers from bad `mailto` and `token`s.
+#' The function emits intermittent messages about the chosen API pool.
+#'
+#' @inheritParams req_user_agent_cr
+req_auth_pool <- function(req, mailto = get_cr_mailto()) {
+  if (could_pool("polite")) {
+    inform_pool("polite")
+    req <- req_user_agent_cr(req, mailto = mailto)
+  } else {
+    inform_pool("public")
+  }
+  req
+}
+
+#' Inform user about email source
+#' @noRd
+inform_pool <- function(pool) {
+  rlang::inform(
+    c(
+      "i" = paste(
+        "Requesting the", pool, "API pool."
+      )
+    ),
+    .frequency = "once",
+    .frequency_id = "inform_pool"
+  )
+}
+
 
 #' @describeIn pools Show the API pool which served a request
 #' @inheritParams httr2::resp_header
 #' @family api pool access functions
 #' @export
-resp_cr_pool <- function(resp) {
-  httr2::resp_header(resp, "x-api-pool")
-}
+resp_cr_pool <- function(resp) httr2::resp_header(resp, "x-api-pool")
 
 #' @describeIn pools Was the request served by the expected pool?
-#' @param pool giving the name of the expected pool.
-#' Listed in order of increasing performance.
+#' Inspects the response header "x-api-pool" of an *existing* response
+#' to see if it matches the expected pool.
+#' @param pool giving the name of the expected pool
 #' @export
-was_pool <- function(resp, pool = c("public", "polite", "plus")) {
+was_pool <- function(resp, pool = pools()) {
   pool <- rlang::arg_match(pool)
   resp_cr_pool(resp) == pool
 }
 
-#' @describeIn pools Can the request be served by an expected pool?
+#' @describeIn pools Can requests be served by an expected pool?
+#' Performs a request to the API and inspects the response header.
 #' @export
-can_pool <- function(pool = c("public", "polite", "plus")) {
+can_pool <- function(pool = pools()) {
   pool <- rlang::arg_match(pool)
   resp_cr_pool(httr2::req_perform(req_head_cr())) == pool
 }
 
+#' @describeIn pools Could the request be served by an expected pool?
+#' Checks whether the necessary credentials can be found
+#' for higher performance pools.
+#' @export
+could_pool <- function(pool = pools()) {
+  pool <- rlang::arg_match(pool)
+  expected_rank <- match(pool, pools())
+  actual_rank <- match(best_pool(), pools())
+  expected_rank <= actual_rank
+}
+
+#' @describeIn pools What is the highest performing pool available?
+#' Checks the necessary credentials for the highest performing pool.
+#' @export
+best_pool <- function(mailto = get_cr_mailto()) {
+  res <- "public"
+  mailto <- try(mailto, silent = TRUE)
+  if (!inherits(mailto, "try-error") && is_email_address(mailto)) {
+    res <- "polite"
+  }
+  res
+}
+
 # mailto for polite ====
 #' Accessing the polite API pool
 #' @name polite
 #' @family api pool access functions
 NULL
 
+
 #' @describeIn polite
 #' Get the email address to authenticate into the polite pool
 #'
 #' Whenever possible, API calls should be identified by an email address
 #' to reach the human responsible for making the call.
-#' In this order, returns the first hit of:
+#' In this order, returns the first valid email found in:
 #'
+#' 1. The `crlite.mailto` option.
 #' 1. The `CR_MD_MAILTO` environment variable
 #'     (recommended only for secure environment variables in the cloud).
 #'
@@ -56,38 +118,44 @@ NULL
 #' 1. The git user email address for the repo at the working directory.
 #'    This
 #'
-#' Or errors out.
+#' Otherwise, the function errors out.
 #' @export
 get_cr_mailto <- function() {
+  mailto <- getOption("crlite.mailto")
+  if (!is.null(mailto)) {
+    inform_mailto_source(mailto = mailto, from = "`crlite.mailto` option")
+    return(mailto)
+  }
   mailto <- Sys.getenv("CR_MD_MAILTO")
-  if (is_email_address(mailto)) {
-    rlang::inform(c(
-      "i" = paste(
-        "Using",
-        mailto,
-        "from environment variable `CR_MD_MAILTO` as a Crossref user."
-      )
-    ))
+  if (mailto != "") {
+    inform_mailto_source(mailto = mailto, from = "`CR_MD_MAILTO` env var")
     return(mailto)
   }
   if (requireNamespace("gert", quietly = TRUE)) {
-    mailto <- try(gert::git_signature_parse(gert::git_signature_default
-    ())$email)
-    if (is_email_address(mailto)) {
-      rlang::inform(
-        c(
-          "i" = paste(
-            "Using", mailto, "from your git config as a Crossref user."
-          )
-        ),
-        .frequency = "once",
-        .frequency_id = "get_cr_mailto"
-      )
+    mailto <- try(
+      gert::git_signature_parse(gert::git_signature_default())$email,
+      silent = TRUE
+    )
+    if (!inherits(mailto, "try-error")) {
+      inform_mailto_source(mailto = mailto, from = "your git config")
       return(mailto)
     }
-  } else {
-    rlang::abort(c("x" = "Could not find a Crossref user."))
   }
+  rlang::abort(c("x" = "Could not find a Crossref user."))
+}
+
+#' Inform user about email source
+#' @noRd
+inform_mailto_source <- function(mailto, from) {
+  rlang::inform(
+    c(
+      "i" = paste(
+        "Using", mailto, "from", from, "as a Crossref user."
+      )
+    ),
+    .frequency = "once",
+    .frequency_id = "get_cr_mailto"
+  )
 }
 
 # token for plus ====