New req_tidy_policy() function to define policies for resp_tidy(). (

#45)

Closes #44.

NAMESPACE

@@ -19,6 +19,7 @@ export(req_modify)
 export(req_perform_opinionated)
 export(req_pkg_user_agent)
 export(req_prepare)
+export(req_tidy_policy)
 export(resp_body_auto)
 export(resp_body_csv)
 export(resp_body_separate)

R/req_modify.R

@@ -39,7 +39,7 @@ req_modify <- function(req,
 
 .req_path_append_impl <- function(req, path) {
   path <- rlang::inject(glue::glue(!!!path, .sep = "/"))
-  path <- url_normalize(path)
+  path <- .path_merge(path)
   req <- httr2::req_url_path_append(req, path)
 }
 

R/req_perform_opinionated.R

@@ -42,6 +42,11 @@ req_perform_opinionated <- function(req,
   return(resps)
 }
 
+#' Add a retry policy if none is defined
+#'
+#' @inheritParams req_perform_opinionated
+#' @inherit req_perform_opinionated return
+#' @keywords internal
 .req_apply_retry_default <- function(req, max_tries_per_req) {
   if (
     any(c("retry_max_wait", "retry_max_tries") %in% names(req$policies)) ||

R/req_policy.R

@@ -0,0 +1,30 @@
+#' Apply policies to a request
+#'
+#' This function is based on the unexported `req_policies()` function from
+#' httr2. It is used to apply policies to a request object. I don't currently
+#' export this function, but that may change in the future.
+#'
+#' @inheritParams .shared-params
+#' @param ...
+#'
+#' @inherit .shared-request return
+#' @keywords internal
+.req_policy <- function(req, ..., call = rlang::caller_env()) {
+  dots <- rlang::list2(...)
+  if (!length(dots)) {
+    return(req)
+  }
+  if (!rlang::is_named(dots)) {
+    .nectar_abort(
+      "All components of {.arg ...} must be named.",
+      "bad_policy",
+      call = call
+    )
+  }
+  req$policies <- req$policies[!names(req$policies) %in% names(dots)]
+  req$policies <- c(req$policies, Filter(length, dots))
+  if (!length(req$policies)) {
+    names(req$policies) <- NULL
+  }
+  return(req)
+}

R/req_tidy_policy.R

@@ -0,0 +1,28 @@
+#' Define a tidy policy for a request
+#'
+#' API responses generally follow a structured format. Use this function to
+#' define a policy that will be used by [resp_tidy()] to extract the relevant
+#' portion of a response and wrangle it into a desired format.
+#'
+#' @inheritParams .shared-params
+#' @param tidy_fn A function that will be invoked by [resp_tidy()] to tidy the
+#'   response.
+#' @param tidy_args A list of additional arguments to pass to `tidy_fn`.
+#'
+#' @inherit .shared-request return
+#' @export
+#'
+#' @examples
+#' req <- httr2::request("https://example.com")
+#' req_tidy_policy(req, httr2::resp_body_json, list(simplifyVector = TRUE))
+req_tidy_policy <- function(req,
+                            tidy_fn = resp_body_auto,
+                            tidy_args = list(),
+                            call = rlang::caller_env()) {
+  tidy_fn <- rlang::as_function(tidy_fn, call = call)
+  .req_policy(
+    req,
+    resp_tidy = list(tidy_fn = tidy_fn, tidy_args = tidy_args),
+    call = call
+  )
+}

R/resp_tidy.R

@@ -5,8 +5,7 @@
 #' API responses generally follow a structured format. Use this function to
 #' extract the relevant portion of a response, and wrangle it into a desired
 #' format. This function is most useful when the response was fetched with a
-#' request that includes a tidying policy (more information about this coming
-#' soon).
+#' request that includes a tidying policy defined via [req_tidy_policy()].
 #'
 #' @inheritParams .shared-params
 #'
@@ -34,9 +33,9 @@ resp_tidy.httr2_response <- function(resps) {
   if (length(req$policies$resp_tidy)) {
     return(
       rlang::exec(
-        req$policies$resp_tidy$fn,
+        req$policies$resp_tidy$tidy_fn,
         resps,
-        !!!req$policies$resp_tidy$args
+        !!!req$policies$resp_tidy$tidy_args
       )
     )
   }

R/utils.R

@@ -99,6 +99,7 @@ url_normalize <- function(url) {
 #' one endpoint might use a special auth function that isn't used by other
 #' endpoints. This function exists to make coding such situations easier.
 #'
+#' @inheritParams .shared-params
 #' @param x An object to potentially modify, such as a [httr2::request()]
 #'   object.
 #' @param fn A function to apply to `x`. If `fn` is `NULL`, `x` is returned
@@ -124,8 +125,9 @@ url_normalize <- function(url) {
 #'   "secure_endpoint", httr2::req_auth_bearer_token, "secret-token"
 #' )
 #' secure_req$headers$Authorization
-do_if_fn_defined <- function(x, fn = NULL, ...) {
-  if (is.function(fn)) {
+do_if_fn_defined <- function(x, fn = NULL, ..., call = rlang::caller_env()) {
+  if (length(fn)) {
+    fn <- rlang::as_function(fn, call = call)
     # Higher-level calls can include !!!'ed arguments.
     dots <- rlang::list2(...)
     x <- rlang::inject(fn(x, !!!dots))
@@ -135,21 +137,16 @@ do_if_fn_defined <- function(x, fn = NULL, ...) {
 
 #' Use a function if args are provided
 #'
-#' @param x An object to potentially modify, such as a [httr2::request()]
-#'   object.
-#' @param fn A function to apply to `x`. If `fn` is `NULL`, `x` is returned
-#'   unchanged.
-#' @param ... Additional arguments to pass to `fn`.
+#' @inheritParams .shared-params
+#' @inheritParams do_if_fn_defined
 #'
-#' @return The object, potentially modified.
+#' @inherit do_if_fn_defined return
 #' @keywords internal
-.do_if_args_defined <- function(x, fn = NULL, ...) {
-  if (is.function(fn)) {
-    dots <- rlang::list2(...)
-    dots <- purrr::discard(dots, is.null)
-    if (length(dots)) {
-      x <- rlang::inject(fn(x, !!!dots))
-    }
+.do_if_args_defined <- function(x, fn = NULL, ..., call = rlang::caller_env()) {
+  dots <- rlang::list2(...)
+  dots <- purrr::discard(dots, is.null)
+  if (length(dots)) {
+    return(do_if_fn_defined(x, fn, !!!dots, call = call))
   }
   return(x)
 }

tests/testthat/test-req_auth_api_key.R

@@ -36,6 +36,13 @@ test_that("req_auth_api_key works for query", {
     api_key = "my_key",
     location = "query"
   )
+  # As of 2025-01-20, httr2 on macos did not insert the "/", but all other OSs
+  # did. Normalizing manually here.
+  test_result$url <- stringr::str_replace(
+    test_result$url,
+    stringr::fixed("/?parm"),
+    stringr::fixed("?parm")
+  )
   expect_identical(
     test_result$url,
     "https://example.com?parm=my_key"

tests/testthat/test-req_policy.R

@@ -0,0 +1,49 @@
+test_that(".req_policy returns reqs unchanged when no policies added", {
+  req <- httr2::request("https://example.com")
+  expect_identical(
+    .req_policy(req),
+    req
+  )
+})
+
+test_that(".req_policy errors informatively for unnamed policies", {
+  req <- httr2::request("https://example.com")
+  expect_error(
+    .req_policy(req, list(my_policy = "whatever")),
+    "must be named",
+    class = "nectar_error-bad_policy"
+  )
+})
+
+test_that(".req_policy applies a policy", {
+  req <- httr2::request("https://example.com")
+  new_policy <- list(a = 1, b = "thing")
+  test_result <- .req_policy(req, new_policy = new_policy)
+  expect_identical(
+    test_result$policies,
+    list(new_policy = new_policy)
+  )
+})
+
+test_that(".req_policy adds to existing policies", {
+  req <- httr2::request("https://example.com")
+  new_policy <- list(a = 1, b = "thing")
+  new_policy2 <- list(a = 2, b = "thing2")
+  req <- .req_policy(req, new_policy = new_policy)
+  test_result <- .req_policy(req, new_policy2 = new_policy2)
+  expect_identical(
+    test_result$policies,
+    list(new_policy = new_policy, new_policy2 = new_policy2)
+  )
+})
+
+test_that(".req_policy removes emptied policies", {
+  req <- httr2::request("https://example.com")
+  new_policy <- list(a = 1, b = "thing")
+  req <- .req_policy(req, new_policy = new_policy)
+  test_result <- .req_policy(req, new_policy = NULL)
+  expect_identical(
+    test_result$policies,
+    list()
+  )
+})