started httr2 integration work #237

R/request_handler-httr2.R

@@ -0,0 +1,116 @@
+sac <- new.env()
+
+#' @title RequestHandlerHttr2
+#' @description Methods for the httr2 package, building on [RequestHandler]
+#' @export
+#' @param request The request from an object of class `HttpInteraction`
+#' @examples \dontrun{
+#' # GET request
+#' library(httr2)
+#' req <- request("https://hb.opencpu.org/post") %>% 
+#'    req_body_json(list(foo = "bar")) 
+#' x <- RequestHandlerHttr2$new(req)
+#' # x$handle()
+#'
+#' # POST request
+#' library(httr2)
+#' mydir <- file.path(tempdir(), "testing_httr2")
+#' invisible(vcr_configure(dir = mydir))
+#' req <- request("https://hb.opencpu.org/post") %>% 
+#'   req_body_json(list(foo = "bar"))
+#' use_cassette(name = "testing3", {
+#'   response <- req_perform(req)
+#' }, match_requests_on = c("method", "uri", "body"))
+#' use_cassette(name = "testing3", {
+#'   response2 <- req_perform(req)
+#' }, match_requests_on = c("method", "uri", "body"))
+#' }
+RequestHandlerHttr2 <- R6::R6Class(
+  "RequestHandlerHttr2",
+  inherit = RequestHandler,
+
+  public = list(
+    #' @description Create a new `RequestHandlerHttr2` object
+    #' @param request The request from an object of class `HttpInteraction`
+    #' @return A new `RequestHandlerHttr2` object
+    initialize = function(request) {
+      if (!length(request$method)) {
+        request$method <- webmockr:::req_method_get_w(request)
+      }
+      self$request_original <- request
+      sac$request_original <- self$request_original
+      self$request <- {
+        Request$new(request$method, request$url,
+          webmockr::pluck_body(request), request$headers,
+          fields = request$fields, opts = request$options, 
+          policies = request$policies)
+      }
+      self$cassette <- tryCatch(current_cassette(), error = function(e) e)
+    }
+  ),
+
+  private = list(
+    # make a `vcr` response
+    response_for = function(x) {
+      VcrResponse$new(
+        list(status_code = x$status_code, description = httr2::resp_status_desc(x)),
+        x$headers,
+        x$body,
+        "",
+        super$cassette$cassette_opts
+      )
+    },
+
+    # these will replace those in
+    on_ignored_request = function(request) {
+      # perform and return REAL http response
+      # * make real request
+      # * run through response_for() to make vcr response, store vcr response
+      # * give back real response
+
+      # real request
+      webmockr::httr2_mock(FALSE)
+      on.exit(webmockr::httr2_mock(TRUE), add = TRUE)
+      tmp2 <- httr2::req_perform(request)
+
+      # run through response_for()
+      self$vcr_response <- private$response_for(tmp2)
+
+      # return real response
+      return(response)
+    },
+
+    on_stubbed_by_vcr_request = function(request) {
+      print("------- on_stubbed_by_vcr_request -------")
+      # return stubbed vcr response - no real response to do
+      sac$request_before_serialize <- request
+      serialize_to_httr2(request, super$get_stubbed_response(request))
+    },
+
+    on_recordable_request = function(request) {
+      print("------- on_recordable_request -------")
+      # do real request - then stub response - then return stubbed vcr response
+      sac$request <- request
+      # real request
+      webmockr::httr2_mock(FALSE)
+      on.exit(webmockr::httr2_mock(TRUE), add = TRUE)
+      tmp2 <- httr2::req_perform(self$request_original)
+      sac$tmp2 <- tmp2
+
+      response <- webmockr::build_httr2_response(self$request_original, tmp2)
+      sac$response <- response
+
+      # make vcr response | then record interaction
+      self$vcr_response <- private$response_for(response)
+      cas <- tryCatch(current_cassette(), error = function(e) e)
+      if (inherits(cas, "error")) stop("no cassette in use")
+      response$request <- self$request_original
+      response$request$method <- webmockr:::req_method_get_w(response$request)
+      cas$record_http_interaction(response)
+
+      # return real response
+      return(response)
+    }
+  )
+)
+

R/serialize_to_httr2.R

@@ -0,0 +1,41 @@
+disk_true <- function(x) {
+  if (is.null(x)) return(FALSE)
+  assert(x, "logical")
+  return(x)
+}
+
+# generate actual httr2 response
+serialize_to_httr2 <- function(request, response) {
+  # request
+  req <- webmockr::RequestSignature$new(
+    method = request$method,
+    uri = request$url,
+    options = list(
+      body = request$body %||% NULL,
+      headers = request$headers %||% NULL,
+      proxies = NULL,
+      auth = NULL,
+      disk = response$disk,
+      fields = request$fields %||% NULL,
+      output = request$output %||% NULL
+    )
+  )
+
+  # response
+  resp <- webmockr::Response$new()
+  resp$set_url(request$uri)
+  resp$set_body(response$body, inherits(response$body, "httr2_path"))
+  resp$set_request_headers(request$headers, capitalize = FALSE)
+  resp$set_response_headers(response$headers, capitalize = FALSE)
+  resp$set_status(status = response$status_code %||% 200)
+
+  # generate httr2 response
+  webmockr::build_httr2_response(as_httr2_request(req), resp)
+}
+
+as_httr2_request <- function(x) {
+  structure(list(url = x$url$url, method = toupper(x$method),
+    headers = x$headers, body = x$body, fields = x$fields,
+    options = x$options, policies = x$policies),
+  class = "httr2_request")
+}