R/cassette_class.R
In ropenscilabs/vcr: Record 'HTTP' Calls to Disk
Defines functions
empty_cassette_message
#' @title Cassette handler
#' @description Main R6 class that is called from the main user facing
#' function [use_cassette()]
#' @export
#' @keywords internal
#' @return an object of class `Cassette`
#' @seealso [vcr_configure()], [use_cassette()], [insert_cassette()]
#' @section Points of webmockr integration:
#' - `initialize()`: webmockr is used in the `initialize()` method to
#' create webmockr stubs. stubs are created on call to `Cassette$new()`
#' within `insert_cassette()`, but then on exiting `use_cassette()`,
#' or calling `eject()` on `Cassette` class from `insert_cassette()`,
#' stubs are cleaned up.
#' - `eject()` method: [webmockr::disable()] is called before exiting
#' eject to disable webmock so that webmockr does not affect any HTTP
#' requests that happen afterwards
#' - `call_block()` method: call_block is used in the [use_cassette()]
#' function to evaluate whatever code is passed to it; within call_block
#' [webmockr::webmockr_allow_net_connect()] is run before we evaluate
#' the code block to allow real HTTP requests, then
#' [webmockr::webmockr_disable_net_connect()] is called after evalulating
#' the code block to disallow real HTTP requests
#' - `make_http_interaction()` method: [webmockr::pluck_body()] utility
#' function is used to pull the request body out of the HTTP request
#' - `serialize_to_crul()` method: method: [webmockr::RequestSignature] and
#' [webmockr::Response] are used to build a request and response,
#' respectively, then passed to [webmockr::build_crul_response()]
#' to make a complete `crul` HTTP response object
#' @examples \dontrun{
#' library(vcr)
#' vcr_configure(dir = tempdir())
#'
#' res <- Cassette$new(name = "bob")
#' res$file()
#' res$originally_recorded_at()
#' res$recording()
#' res$serializable_hash()
#' res$eject()
#' res$should_remove_matching_existing_interactions()
#' res$storage_key()
#' res$match_requests_on
#'
#' # record all requests
#' res <- Cassette$new("foobar", record = "all")
#' res$eject()
#'
#' # cleanup
#' unlink(file.path(tempdir(), c("bob.yml", "foobar.yml")))
#'
#' library(vcr)
#' vcr_configure(dir = tempdir())
#' res <- Cassette$new(name = "jane")
#' library(crul)
#' # HttpClient$new("https://hb.opencpu.org")$get("get")
#' }
Cassette <- R6::R6Class(
"Cassette",
public = list(
#' @field name (character) cassette name
name = NA,
#' @field record (character) record mode
record = "all",
#' @field manfile (character) cassette file path
manfile = NA,
#' @field recorded_at (character) date/time recorded at
recorded_at = NA,
#' @field serialize_with (character) serializer to use (yaml|json)
serialize_with = "yaml",
#' @field serializer (character) serializer to use (yaml|json)
serializer = NA,
#' @field persist_with (character) persister to use (FileSystem only)
persist_with = "FileSystem",
#' @field persister (character) persister to use (FileSystem only)
persister = NA,
#' @field match_requests_on (character) matchers to use
#' default: method & uri
match_requests_on = c("method", "uri"),
#' @field re_record_interval (numeric) the re-record interval
re_record_interval = NULL,
#' @field tag ignored, not used right now
tag = NA,
#' @field tags ignored, not used right now
tags = NA,
#' @field root_dir root dir, gathered from [vcr_configuration()]
root_dir = NA,
#' @field update_content_length_header (logical) Whether to overwrite the
#' `Content-Length` header
update_content_length_header = FALSE,
#' @field allow_playback_repeats (logical) Whether to allow a single HTTP
#' interaction to be played back multiple times
allow_playback_repeats = FALSE,
#' @field allow_unused_http_interactions (logical) ignored, not used right now
allow_unused_http_interactions = TRUE,
#' @field exclusive (logical) ignored, not used right now
exclusive = FALSE,
#' @field preserve_exact_body_bytes (logical) Whether to base64 encode the
#' bytes of the requests and responses
preserve_exact_body_bytes = FALSE,
#' @field args (list) internal use
args = list(),
#' @field http_interactions_ (list) internal use
http_interactions_ = NULL,
#' @field new_recorded_interactions (list) internal use
new_recorded_interactions = NULL,
#' @field clean_outdated_http_interactions (logical) Should outdated interactions
#' be recorded back to file
clean_outdated_http_interactions = FALSE,
#' @field to_return (logical) internal use
to_return = NULL,
#' @field cassette_opts (list) various cassette options
cassette_opts = NULL,
#' @description Create a new `Cassette` object
#' @param name The name of the cassette. vcr will sanitize this to ensure it
#' is a valid file name.
#' @param record The record mode. Default: "once". In the future we'll support
#' "once", "all", "none", "new_episodes". See [recording] for more information
#' @param serialize_with (character) Which serializer to use.
#' Valid values are "yaml" (default), the only one supported for now.
#' @param persist_with (character) Which cassette persister to
#' use. Default: "file_system". You can also register and use a
#' custom persister.
#' @param match_requests_on List of request matchers
#' to use to determine what recorded HTTP interaction to replay. Defaults to
#' `["method", "uri"]`. The built-in matchers are "method", "uri",
#' "headers" and "body" ("host" and "path" not supported yet, but should
#' be in a future version)
#' @param re_record_interval (numeric) When given, the cassette will be
#' re-recorded at the given interval, in seconds.
#' @param tag,tags tags ignored, not used right now
#' @param update_content_length_header (logical) Whether or
#' not to overwrite the `Content-Length` header of the responses to
#' match the length of the response body. Default: `FALSE`
#' @param allow_playback_repeats (logical) Whether or not to
#' allow a single HTTP interaction to be played back multiple times.
#' Default: `FALSE`.
#' @param allow_unused_http_interactions (logical) ignored, not used right now
#' @param exclusive (logical) ignored, not used right now
#' @param preserve_exact_body_bytes (logical) Whether or not
#' to base64 encode the bytes of the requests and responses for
#' this cassette when serializing it. See also `preserve_exact_body_bytes`
#' in [vcr_configure()]. Default: `FALSE`
#' @param clean_outdated_http_interactions (logical) Should outdated interactions
#' be recorded back to file. Default: `FALSE`
#' @return A new `Cassette` object
initialize = function(
name, record, serialize_with, persist_with, match_requests_on,
re_record_interval, tag, tags, update_content_length_header,
allow_playback_repeats, allow_unused_http_interactions,
exclusive, preserve_exact_body_bytes,
clean_outdated_http_interactions) {
self$name <- name
self$root_dir <- vcr_configuration()$dir
self$serialize_with <- serialize_with %||% vcr_c$serialize_with
check_serializer(self$serialize_with)
self$persist_with <- persist_with %||% vcr_c$persist_with
if (!missing(record)) {
self$record <- check_record_mode(record)
}
self$make_dir()
ext <- switch(self$serialize_with, yaml = "yml", json = "json")
self$manfile <- sprintf("%s/%s.%s", path.expand(cassette_path()),
self$name, ext)
if (!file.exists(self$manfile)) cat("\n", file = self$manfile)
if (!missing(match_requests_on)) {
self$match_requests_on <- check_request_matchers(match_requests_on)
}
if (!missing(re_record_interval))
self$re_record_interval <- re_record_interval
if (!missing(tag)) self$tag = tag
if (!missing(tags)) self$tags = tags
if (!missing(update_content_length_header)) {
assert(update_content_length_header, "logical")
self$update_content_length_header = update_content_length_header
}
if (!missing(allow_playback_repeats)) {
assert(allow_playback_repeats, "logical")
self$allow_playback_repeats = allow_playback_repeats
}
if (!missing(allow_unused_http_interactions))
self$allow_unused_http_interactions = allow_unused_http_interactions
if (!missing(exclusive)) self$exclusive = exclusive
if (!missing(preserve_exact_body_bytes)) {
assert(preserve_exact_body_bytes, "logical")
self$preserve_exact_body_bytes <- preserve_exact_body_bytes
}
if (!missing(clean_outdated_http_interactions)) {
self$clean_outdated_http_interactions <- clean_outdated_http_interactions
}
self$make_args()
if (!file.exists(self$manfile)) self$write_metadata()
self$recorded_at <- file.info(self$file())$mtime
self$serializer = serializer_fetch(self$serialize_with, self$name)
self$persister = persister_fetch(self$persist_with, self$serializer$path)
# check for re-record
if (self$should_re_record()) self$record <- "all"
# get previously recorded interactions
## if none pass, if some found, make webmockr stubs
#### first, get previously recorded interactions into `http_interactions_` var
self$http_interactions()
# then do the rest
prev <- self$previously_recorded_interactions()
if (length(prev) > 0) {
stub_previous_request <- function(previous_interaction) {
req <- previous_interaction$request
res <- previous_interaction$response
uripp <- crul::url_parse(req$uri)
m <- self$match_requests_on
.stub_request_with <- function(match_parameters, request) {
.check_match_parameters <- function(mp) {
vmp <- c("method", "uri", "body", "headers", "query")
mp[mp %in% vmp]
}
mp <- .check_match_parameters(match_parameters)
stub_method <- ifelse("method" %in% mp,
req$method,
"any"
)
stub_uri <- ifelse(identical(mp, c("body")),
".+",
ifelse("uri" %in% mp,
req$uri,
"."
)
)
if (stub_uri %in% c(".", ".+")) {
sr <- webmockr::stub_request(method = stub_method,
uri_regex = stub_uri)
} else {
sr <- webmockr::stub_request(method = stub_method,
uri = stub_uri)
}
with_list <- list()
if ("query" %in% mp) {
with_list[["query"]] <- uripp$parameter
}
if ("headers" %in% mp) {
with_list[["headers"]] <- req$headers
}
if ("body" %in% mp) {
with_list[["body"]] <- req$body
}
# if list is empty, skip wi_th
if (length(with_list) != 0) webmockr::wi_th(sr, .list = with_list)
}
.stub_request_with(m, req)
}
invisible(lapply(prev, stub_previous_request))
}
tmp <- list(
self$name,
self$record,
self$serialize_with,
self$persist_with,
self$match_requests_on,
self$update_content_length_header,
self$allow_playback_repeats,
self$preserve_exact_body_bytes
)
init_opts <- compact(
stats::setNames(tmp, c("name", "record", "serialize_with",
"persist_with", "match_requests_on", "update_content_length_header",
"allow_playback_repeats", "preserve_exact_body_bytes")))
self$cassette_opts <- init_opts
init_opts <- paste(names(init_opts), unname(init_opts), sep = ": ",
collapse = ", ")
vcr_log_info(sprintf("Initialized with options: {%s}", init_opts),
vcr_c$log_opts$date)
# create new env for recorded interactions
self$new_recorded_interactions <- list()
# check on write to disk path
if (!is.null(vcr_c$write_disk_path))
dir.create(vcr_c$write_disk_path, showWarnings = FALSE, recursive = TRUE)
# put cassette in vcr_cassettes environment
include_cassette(self)
},
#' @description print method for `Cassette` objects
#' @param x self
#' @param ... ignored
print = function(x, ...) {
cat(paste0("<vcr - Cassette> ", self$name), sep = "\n")
cat(paste0(" Record method: ", self$record), sep = "\n")
cat(paste0(" Serialize with: ", self$serialize_with), sep = "\n")
cat(paste0(" Persist with: ", self$persist_with), sep = "\n")
cat(paste0(" Re-record interval (s): ", self$re_record_interval),
sep = "\n")
cat(paste0(" Clean outdated interactions?: ",
self$clean_outdated_http_interactions), sep = "\n")
cat(paste0(" update_content_length_header: ",
self$update_content_length_header), sep = "\n")
cat(paste0(" allow_playback_repeats: ",
self$allow_playback_repeats), sep = "\n")
cat(paste0(" allow_unused_http_interactions: ",
self$allow_unused_http_interactions), sep = "\n")
cat(paste0(" exclusive: ", self$exclusive), sep = "\n")
cat(paste0(" preserve_exact_body_bytes: ",
self$preserve_exact_body_bytes), sep = "\n")
invisible(self)
},
#' @description run code
#' @param ... pass in things to be evaluated
#' @return various
call_block = function(...) {
tmp <- list(...)
if (length(tmp) == 0) {
stop("`vcr::use_cassette` requires a code block. ",
"If you cannot wrap your code in a block, use ",
"`vcr::insert_cassette` / `vcr::eject_cassette` instead")
}
invisible(force(...))
},
#' @description ejects the current cassette
#' @return self
eject = function() {
on.exit(private$remove_empty_cassette())
self$write_recorded_interactions_to_disk()
# remove cassette from list of current cassettes
rm(list = self$name, envir = vcr_cassettes)
if (!vcr_c$quiet) message("ejecting cassette: ", self$name)
# disable webmockr
webmockr::disable(quiet=vcr_c$quiet)
# set current casette name to NULL
vcr__env$current_cassette <- NULL
# return self
return(self)
},
#' @description get the file path for the cassette
#' @return character
file = function() self$manfile,
#' @description is the cassette in recording mode?
#' @return logical
recording = function() {
if (self$record == "none") {
return(FALSE)
} else if (self$record == "once") {
return(self$is_empty())
} else {
return(TRUE)
}
},
#' @description is the cassette on disk empty
#' @return logical
is_empty = function() {
nchar(self$raw_cassette_bytes()) < 1
},
#' @description timestamp the cassette was originally recorded at
#' @return POSIXct date
originally_recorded_at = function() {
as.POSIXct(self$recorded_at, tz = "GMT")
},
#' @description Get a list of the http interactions to record + recorded_with
#' @return list
serializable_hash = function() {
list(
http_interactions = self$interactions_to_record(),
recorded_with = utils::packageVersion("vcr")
)
},
#' @description Get the list of http interactions to record
#' @return list
interactions_to_record = function() {
## FIXME - gotta sort out defining and using hooks better
## just returning exact same input
self$merged_interactions()
# FIXME: not sure what's going on here, so not using yet
#. maybe we don't need this?
# "We dee-dupe the interactions by roundtripping them to/from a hash.
# This is necessary because `before_record` can mutate the interactions."
# lapply(self$merged_interactions(), function(z) {
# VCRHooks$invoke_hook("before_record", z)
# })
},
#' @description Get interactions to record
#' @return list
merged_interactions = function() {
old_interactions <- self$previously_recorded_interactions()
old_interactions <- lapply(old_interactions, function(x) {
HTTPInteraction$new(
request = x$request,
response = x$response,
recorded_at = x$recorded_at)
})
if (self$should_remove_matching_existing_interactions()) {
new_interaction_list <-
HTTPInteractionList$new(self$new_recorded_interactions,
self$match_requests_on)
old_interactions <-
Filter(function(x) {
req <- Request$new()$from_hash(x$request)
!unlist(new_interaction_list$has_interaction_matching(req))
},
old_interactions
)
}
return(c(self$up_to_date_interactions(old_interactions),
self$new_recorded_interactions))
},
#' @description Cleans out any old interactions based on the
#' re_record_interval and clean_outdated_http_interactions settings
#' @param interactions list of http interactions, of class [HTTPInteraction]
#' @return list of interactions to record
up_to_date_interactions = function(interactions) {
if (
!self$clean_outdated_http_interactions && is.null(self$re_record_interval)
) {
return(interactions)
}
Filter(function(z) {
as.POSIXct(z$recorded_at, tz = "GMT") > (as.POSIXct(Sys.time(), tz = "GMT") - self$re_record_interval)
}, interactions)
},
#' @description Should re-record interactions?
#' @return logical
should_re_record = function() {
if (is.null(self$re_record_interval)) return(FALSE)
if (is.null(self$originally_recorded_at())) return(FALSE)
now <- as.POSIXct(Sys.time(), tz = "GMT")
time_comp <- (self$originally_recorded_at() + self$re_record_interval) < now
info <- sprintf(
"previously recorded at: '%s'; now: '%s'; interval: %s seconds",
self$originally_recorded_at(), now, self$re_record_interval)
if (!time_comp) {
vcr_log_info(
sprintf("Not re-recording since the interval has not elapsed (%s).", info),
vcr_c$log_opts$date)
return(FALSE)
} else if (has_internet()) {
vcr_log_info(sprintf("re-recording (%s).", info), vcr_c$log_opts$date)
return(TRUE)
} else {
vcr_log_info(
sprintf("Not re-recording because no internet connection is available (%s).", info),
vcr_c$log_opts$date)
return(FALSE)
}
},
#' @description Is record mode NOT "all"?
#' @return logical
should_stub_requests = function() {
self$record != "all"
},
#' @description Is record mode "all"?
#' @return logical
should_remove_matching_existing_interactions = function() {
self$record == "all"
},
#' @description Get the serializer path
#' @return character
storage_key = function() self$serializer$path,
#' @description Get character string of entire cassette; bytes is a misnomer
#' @return character
raw_cassette_bytes = function() {
file <- self$file()
if (is.null(file)) return("")
tmp <- readLines(file) %||% ""
paste0(tmp, collapse = "")
},
#' @description Create the directory that holds the cassettes, if not present
#' @return no return; creates a directory recursively, if missing
make_dir = function() {
dir.create(path.expand(self$root_dir), showWarnings = FALSE,
recursive = TRUE)
},
#' @description get http interactions from the cassette via the serializer
#' @return list
deserialized_hash = function() {
tmp <- self$serializer$deserialize(self)
if (inherits(tmp, "list")) {
return(tmp)
} else {
stop(tmp, " does not appear to be a valid cassette", call. = FALSE)
}
},
#' @description get all previously recorded interactions
#' @return list
previously_recorded_interactions = function() {
if (nchar(self$raw_cassette_bytes()) > 0) {
tmp <- compact(
lapply(self$deserialized_hash()[["http_interactions"]], function(z) {
response <- VcrResponse$new(
z$response$status,
z$response$headers,
z$response$body$string %||% z$response$body$base64_string,
opts = self$cassette_opts,
disk = z$response$body$file
)
if (self$update_content_length_header)
response$update_content_length_header()
zz <- HTTPInteraction$new(
request = Request$new(z$request$method,
z$request$uri,
z$request$body$string,
z$request$headers,
disk = z$response$body$file),
response = response
)
hash <- zz$to_hash()
if (request_ignorer$should_be_ignored(hash$request)) NULL else hash
}))
return(tmp)
} else {
return(list())
}
},
#' @description write recorded interactions to disk
#' @return nothing returned
write_recorded_interactions_to_disk = function() {
if (!self$any_new_recorded_interactions()) return(NULL)
hash <- self$serializable_hash()
if (length(hash[["http_interactions"]]) == 0) return(NULL)
fun <- self$serializer$serialize()
fun(hash[[1]], self$persister$file_name, self$preserve_exact_body_bytes)
},
#' @description record an http interaction (doesn't write to disk)
#' @param x an crul or httr response object, with the request at `$request`
#' @return nothing returned
record_http_interaction = function(x) {
int <- self$make_http_interaction(x)
self$http_interactions_$response_for(int$request)
vcr_log_info(sprintf(" Recorded HTTP interaction: %s => %s",
request_summary(int$request), response_summary(int$response)),
vcr_c$log_opts$date)
self$new_recorded_interactions <- c(self$new_recorded_interactions, int)
},
#' @description Are there any new recorded interactions?
#' @return logical
any_new_recorded_interactions = function() {
length(self$new_recorded_interactions) != 0
},
#' @description make list of all options
#' @return nothing returned
make_args = function() {
self$args <- list(
record = self$record,
match_requests_on = self$match_requests_on,
re_record_interval = self$re_record_interval,
tag = self$tag, tags = self$tags,
update_content_length_header = self$update_content_length_header,
allow_playback_repeats = self$allow_playback_repeats,
allow_unused_http_interactions = self$allow_unused_http_interactions,
exclusive = self$exclusive, serialize_with = self$serialize_with,
persist_with = self$persist_with,
preserve_exact_body_bytes = self$preserve_exact_body_bytes
)
},
#' @description write metadata to the cassette
#' @return nothing returned
write_metadata = function() {
aa <- c(name = self$name, self$args)
for (i in seq_along(aa)) {
cat(sprintf("%s: %s", names(aa[i]), aa[i]),
file = sprintf("%s/%s_metadata.yml",
path.expand(cassette_path()), self$name),
sep = "\n", append = TRUE)
}
},
#' @description make [HTTPInteractionList] object, assign to http_interactions_ var
#' @return nothing returned
http_interactions = function() {
self$http_interactions_ <- HTTPInteractionList$new(
interactions = {
if (self$should_stub_requests()) {
self$previously_recorded_interactions()
} else {
list()
}
},
request_matchers = self$match_requests_on
# request_matchers = vcr_configuration()$match_requests_on
)
},
#' @description Make an `HTTPInteraction` object
#' @param x an crul or httr response object, with the request at `$request`
#' @return an object of class [HTTPInteraction]
make_http_interaction = function(x) {
# content must be raw or character
assert(unclass(x$content), c('raw', 'character'))
new_file_path <- ""
is_disk <- FALSE
if (is.character(x$content)) {
if (file.exists(x$content)) {
is_disk <- TRUE
write_disk_path <- vcr_c$write_disk_path
if (is.null(write_disk_path))
stop("if writing to disk, write_disk_path must be given; ",
"see ?vcr_configure")
new_file_path <- file.path(write_disk_path, basename(x$content))
}
}
request <- Request$new(
method = x$request$method,
uri = x$url,
body = if (inherits(x, "response")) { # httr
bd <- webmockr::pluck_body(x$request)
if (inherits(bd, "raw")) rawToChar(bd) else bd
} else { # crul
webmockr::pluck_body(x$request)
},
headers = if (inherits(x, "response")) {
as.list(x$request$headers)
} else {
x$request_headers
},
opts = self$cassette_opts,
disk = is_disk,
skip_port_stripping = TRUE
)
response <- VcrResponse$new(
status = if (inherits(x, "response")) {
c(list(status_code = x$status_code), httr::http_status(x))
} else unclass(x$status_http()),
headers = if (inherits(x, "response")) x$headers else x$response_headers,
body = if (is.raw(x$content)) {
if (can_rawToChar(x$content)) rawToChar(x$content) else x$content
} else {
stopifnot(inherits(unclass(x$content), "character"))
if (file.exists(x$content)) {
# calculate new file path in fixtures/
# copy file into fixtures/file_cache/
# don't move b/c don't want to screw up first use before using
# cached request
file.copy(x$content, write_disk_path,
overwrite = TRUE, recursive = TRUE) # copy the file
new_file_path
# raw(0)
} else {
x$content
}
},
http_version = if (inherits(x, "response")) {
x$all_headers[[1]]$version
} else {
x$response_headers$status
},
opts = self$cassette_opts,
disk = is_disk
)
if (self$update_content_length_header)
response$update_content_length_header()
HTTPInteraction$new(request = request, response = response)
},
#' @description Make a crul response object
#' @return a crul response
serialize_to_crul = function() {
if (length(self$deserialized_hash()) != 0) {
intr <- self$deserialized_hash()[[1]][[1]]
} else {
intr <- tryCatch(
self$previously_recorded_interactions()[[1]],
error = function(e) e
)
if (inherits(intr, "error")) {
intr <- tryCatch(
self$new_recorded_interactions[[1]],
error = function(e) e
)
if (inherits(intr, "error")) {
stop("no requests found to construct a crul response")
}
}
}
# request
req <- webmockr::RequestSignature$new(
method = intr$request$method,
uri = intr$request$uri,
options = list(
body = intr$request$body %||% NULL,
headers = intr$request$headers %||% NULL,
proxies = NULL,
auth = NULL
)
)
# response
resp <- webmockr::Response$new()
resp$set_url(intr$request$uri)
bod <- intr$response$body
resp$set_body(if ("string" %in% names(bod)) bod$string else bod)
resp$set_request_headers(intr$request$headers)
resp$set_response_headers(intr$response$headers)
resp$set_status(status = intr$response$status$status_code %||% 200)
# generate crul response
webmockr::build_crul_response(req, resp)
}
),
private = list(
remove_empty_cassette = function() {
if (!any(nzchar(readLines(self$file())))) {
unlink(self$file(), force = TRUE)
if (vcr_c$warn_on_empty_cassette)
warning(empty_cassette_message(self$name), call. = FALSE)
}
}
)
)
empty_cassette_message <- function(x) {
c(
sprintf("Empty cassette (%s) deleted; consider the following:\n", x),
" - If an error occurred resolve that first, then check:\n",
" - vcr only supports crul & httr; requests w/ curl, download.file, etc. are not supported\n",
" - If you are using crul/httr, are you sure you made an HTTP request?\n")
}
ropenscilabs/vcr documentation built on Feb. 5, 2024, 5:58 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions empty_cassette_message
#' @title Cassette handler
#' @description Main R6 class that is called from the main user facing
#' function [use_cassette()]
#' @export
#' @keywords internal
#' @return an object of class `Cassette`
#' @seealso [vcr_configure()], [use_cassette()], [insert_cassette()]
#' @section Points of webmockr integration:
#' - `initialize()`: webmockr is used in the `initialize()` method to
#' create webmockr stubs. stubs are created on call to `Cassette$new()`
#' within `insert_cassette()`, but then on exiting `use_cassette()`,
#' or calling `eject()` on `Cassette` class from `insert_cassette()`,
#' stubs are cleaned up.
#' - `eject()` method: [webmockr::disable()] is called before exiting
#' eject to disable webmock so that webmockr does not affect any HTTP
#' requests that happen afterwards
#' - `call_block()` method: call_block is used in the [use_cassette()]
#' function to evaluate whatever code is passed to it; within call_block
#' [webmockr::webmockr_allow_net_connect()] is run before we evaluate
#' the code block to allow real HTTP requests, then
#' [webmockr::webmockr_disable_net_connect()] is called after evalulating
#' the code block to disallow real HTTP requests
#' - `make_http_interaction()` method: [webmockr::pluck_body()] utility
#' function is used to pull the request body out of the HTTP request
#' - `serialize_to_crul()` method: method: [webmockr::RequestSignature] and
#' [webmockr::Response] are used to build a request and response,
#' respectively, then passed to [webmockr::build_crul_response()]
#' to make a complete `crul` HTTP response object
#' @examples \dontrun{
#' library(vcr)
#' vcr_configure(dir = tempdir())
#'
#' res <- Cassette$new(name = "bob")
#' res$file()
#' res$originally_recorded_at()
#' res$recording()
#' res$serializable_hash()
#' res$eject()
#' res$should_remove_matching_existing_interactions()
#' res$storage_key()
#' res$match_requests_on
#'
#' # record all requests
#' res <- Cassette$new("foobar", record = "all")
#' res$eject()
#'
#' # cleanup
#' unlink(file.path(tempdir(), c("bob.yml", "foobar.yml")))
#'
#' library(vcr)
#' vcr_configure(dir = tempdir())
#' res <- Cassette$new(name = "jane")
#' library(crul)
#' # HttpClient$new("https://hb.opencpu.org")$get("get")
#' }
Cassette <- R6::R6Class(
"Cassette",
public = list(
#' @field name (character) cassette name
name = NA,
#' @field record (character) record mode
record = "all",
#' @field manfile (character) cassette file path
manfile = NA,
#' @field recorded_at (character) date/time recorded at
recorded_at = NA,
#' @field serialize_with (character) serializer to use (yaml|json)
serialize_with = "yaml",
#' @field serializer (character) serializer to use (yaml|json)
serializer = NA,
#' @field persist_with (character) persister to use (FileSystem only)
persist_with = "FileSystem",
#' @field persister (character) persister to use (FileSystem only)
persister = NA,
#' @field match_requests_on (character) matchers to use
#' default: method & uri
match_requests_on = c("method", "uri"),
#' @field re_record_interval (numeric) the re-record interval
re_record_interval = NULL,
#' @field tag ignored, not used right now
tag = NA,
#' @field tags ignored, not used right now
tags = NA,
#' @field root_dir root dir, gathered from [vcr_configuration()]
root_dir = NA,
#' @field update_content_length_header (logical) Whether to overwrite the
#' `Content-Length` header
update_content_length_header = FALSE,
#' @field allow_playback_repeats (logical) Whether to allow a single HTTP
#' interaction to be played back multiple times
allow_playback_repeats = FALSE,
#' @field allow_unused_http_interactions (logical) ignored, not used right now
allow_unused_http_interactions = TRUE,
#' @field exclusive (logical) ignored, not used right now
exclusive = FALSE,
#' @field preserve_exact_body_bytes (logical) Whether to base64 encode the
#' bytes of the requests and responses
preserve_exact_body_bytes = FALSE,
#' @field args (list) internal use
args = list(),
#' @field http_interactions_ (list) internal use
http_interactions_ = NULL,
#' @field new_recorded_interactions (list) internal use
new_recorded_interactions = NULL,
#' @field clean_outdated_http_interactions (logical) Should outdated interactions
#' be recorded back to file
clean_outdated_http_interactions = FALSE,
#' @field to_return (logical) internal use
to_return = NULL,
#' @field cassette_opts (list) various cassette options
cassette_opts = NULL,
#' @description Create a new `Cassette` object
#' @param name The name of the cassette. vcr will sanitize this to ensure it
#' is a valid file name.
#' @param record The record mode. Default: "once". In the future we'll support
#' "once", "all", "none", "new_episodes". See [recording] for more information
#' @param serialize_with (character) Which serializer to use.
#' Valid values are "yaml" (default), the only one supported for now.
#' @param persist_with (character) Which cassette persister to
#' use. Default: "file_system". You can also register and use a
#' custom persister.
#' @param match_requests_on List of request matchers
#' to use to determine what recorded HTTP interaction to replay. Defaults to
#' `["method", "uri"]`. The built-in matchers are "method", "uri",
#' "headers" and "body" ("host" and "path" not supported yet, but should
#' be in a future version)
#' @param re_record_interval (numeric) When given, the cassette will be
#' re-recorded at the given interval, in seconds.
#' @param tag,tags tags ignored, not used right now
#' @param update_content_length_header (logical) Whether or
#' not to overwrite the `Content-Length` header of the responses to
#' match the length of the response body. Default: `FALSE`
#' @param allow_playback_repeats (logical) Whether or not to
#' allow a single HTTP interaction to be played back multiple times.
#' Default: `FALSE`.
#' @param allow_unused_http_interactions (logical) ignored, not used right now
#' @param exclusive (logical) ignored, not used right now
#' @param preserve_exact_body_bytes (logical) Whether or not
#' to base64 encode the bytes of the requests and responses for
#' this cassette when serializing it. See also `preserve_exact_body_bytes`
#' in [vcr_configure()]. Default: `FALSE`
#' @param clean_outdated_http_interactions (logical) Should outdated interactions
#' be recorded back to file. Default: `FALSE`
#' @return A new `Cassette` object
initialize = function(
name, record, serialize_with, persist_with, match_requests_on,
re_record_interval, tag, tags, update_content_length_header,
allow_playback_repeats, allow_unused_http_interactions,
exclusive, preserve_exact_body_bytes,
clean_outdated_http_interactions) {
self$name <- name
self$root_dir <- vcr_configuration()$dir
self$serialize_with <- serialize_with %||% vcr_c$serialize_with
check_serializer(self$serialize_with)
self$persist_with <- persist_with %||% vcr_c$persist_with
if (!missing(record)) {
self$record <- check_record_mode(record)
}
self$make_dir()
ext <- switch(self$serialize_with, yaml = "yml", json = "json")
self$manfile <- sprintf("%s/%s.%s", path.expand(cassette_path()),
self$name, ext)
if (!file.exists(self$manfile)) cat("\n", file = self$manfile)
if (!missing(match_requests_on)) {
self$match_requests_on <- check_request_matchers(match_requests_on)
}
if (!missing(re_record_interval))
self$re_record_interval <- re_record_interval
if (!missing(tag)) self$tag = tag
if (!missing(tags)) self$tags = tags
if (!missing(update_content_length_header)) {
assert(update_content_length_header, "logical")
self$update_content_length_header = update_content_length_header
}
if (!missing(allow_playback_repeats)) {
assert(allow_playback_repeats, "logical")
self$allow_playback_repeats = allow_playback_repeats
}
if (!missing(allow_unused_http_interactions))
self$allow_unused_http_interactions = allow_unused_http_interactions
if (!missing(exclusive)) self$exclusive = exclusive
if (!missing(preserve_exact_body_bytes)) {
assert(preserve_exact_body_bytes, "logical")
self$preserve_exact_body_bytes <- preserve_exact_body_bytes
}
if (!missing(clean_outdated_http_interactions)) {
self$clean_outdated_http_interactions <- clean_outdated_http_interactions
}
self$make_args()
if (!file.exists(self$manfile)) self$write_metadata()
self$recorded_at <- file.info(self$file())$mtime
self$serializer = serializer_fetch(self$serialize_with, self$name)
self$persister = persister_fetch(self$persist_with, self$serializer$path)
# check for re-record
if (self$should_re_record()) self$record <- "all"
# get previously recorded interactions
## if none pass, if some found, make webmockr stubs
#### first, get previously recorded interactions into `http_interactions_` var
self$http_interactions()
# then do the rest
prev <- self$previously_recorded_interactions()
if (length(prev) > 0) {
stub_previous_request <- function(previous_interaction) {
req <- previous_interaction$request
res <- previous_interaction$response
uripp <- crul::url_parse(req$uri)
m <- self$match_requests_on
.stub_request_with <- function(match_parameters, request) {
.check_match_parameters <- function(mp) {
vmp <- c("method", "uri", "body", "headers", "query")
mp[mp %in% vmp]
}
mp <- .check_match_parameters(match_parameters)
stub_method <- ifelse("method" %in% mp,
req$method,
"any"
)
stub_uri <- ifelse(identical(mp, c("body")),
".+",
ifelse("uri" %in% mp,
req$uri,
"."
)
)
if (stub_uri %in% c(".", ".+")) {
sr <- webmockr::stub_request(method = stub_method,
uri_regex = stub_uri)
} else {
sr <- webmockr::stub_request(method = stub_method,
uri = stub_uri)
}
with_list <- list()
if ("query" %in% mp) {
with_list[["query"]] <- uripp$parameter
}
if ("headers" %in% mp) {
with_list[["headers"]] <- req$headers
}
if ("body" %in% mp) {
with_list[["body"]] <- req$body
}
# if list is empty, skip wi_th
if (length(with_list) != 0) webmockr::wi_th(sr, .list = with_list)
}
.stub_request_with(m, req)
}
invisible(lapply(prev, stub_previous_request))
}
tmp <- list(
self$name,
self$record,
self$serialize_with,
self$persist_with,
self$match_requests_on,
self$update_content_length_header,
self$allow_playback_repeats,
self$preserve_exact_body_bytes
)
init_opts <- compact(
stats::setNames(tmp, c("name", "record", "serialize_with",
"persist_with", "match_requests_on", "update_content_length_header",
"allow_playback_repeats", "preserve_exact_body_bytes")))
self$cassette_opts <- init_opts
init_opts <- paste(names(init_opts), unname(init_opts), sep = ": ",
collapse = ", ")
vcr_log_info(sprintf("Initialized with options: {%s}", init_opts),
vcr_c$log_opts$date)
# create new env for recorded interactions
self$new_recorded_interactions <- list()
# check on write to disk path
if (!is.null(vcr_c$write_disk_path))
dir.create(vcr_c$write_disk_path, showWarnings = FALSE, recursive = TRUE)
# put cassette in vcr_cassettes environment
include_cassette(self)
},
#' @description print method for `Cassette` objects
#' @param x self
#' @param ... ignored
print = function(x, ...) {
cat(paste0("<vcr - Cassette> ", self$name), sep = "\n")
cat(paste0(" Record method: ", self$record), sep = "\n")
cat(paste0(" Serialize with: ", self$serialize_with), sep = "\n")
cat(paste0(" Persist with: ", self$persist_with), sep = "\n")
cat(paste0(" Re-record interval (s): ", self$re_record_interval),
sep = "\n")
cat(paste0(" Clean outdated interactions?: ",
self$clean_outdated_http_interactions), sep = "\n")
cat(paste0(" update_content_length_header: ",
self$update_content_length_header), sep = "\n")
cat(paste0(" allow_playback_repeats: ",
self$allow_playback_repeats), sep = "\n")
cat(paste0(" allow_unused_http_interactions: ",
self$allow_unused_http_interactions), sep = "\n")
cat(paste0(" exclusive: ", self$exclusive), sep = "\n")
cat(paste0(" preserve_exact_body_bytes: ",
self$preserve_exact_body_bytes), sep = "\n")
invisible(self)
},
#' @description run code
#' @param ... pass in things to be evaluated
#' @return various
call_block = function(...) {
tmp <- list(...)
if (length(tmp) == 0) {
stop("`vcr::use_cassette` requires a code block. ",
"If you cannot wrap your code in a block, use ",
"`vcr::insert_cassette` / `vcr::eject_cassette` instead")
}
invisible(force(...))
},
#' @description ejects the current cassette
#' @return self
eject = function() {
on.exit(private$remove_empty_cassette())
self$write_recorded_interactions_to_disk()
# remove cassette from list of current cassettes
rm(list = self$name, envir = vcr_cassettes)
if (!vcr_c$quiet) message("ejecting cassette: ", self$name)
# disable webmockr
webmockr::disable(quiet=vcr_c$quiet)
# set current casette name to NULL
vcr__env$current_cassette <- NULL
# return self
return(self)
},
#' @description get the file path for the cassette
#' @return character
file = function() self$manfile,
#' @description is the cassette in recording mode?
#' @return logical
recording = function() {
if (self$record == "none") {
return(FALSE)
} else if (self$record == "once") {
return(self$is_empty())
} else {
return(TRUE)
}
},
#' @description is the cassette on disk empty
#' @return logical
is_empty = function() {
nchar(self$raw_cassette_bytes()) < 1
},
#' @description timestamp the cassette was originally recorded at
#' @return POSIXct date
originally_recorded_at = function() {
as.POSIXct(self$recorded_at, tz = "GMT")
},
#' @description Get a list of the http interactions to record + recorded_with
#' @return list
serializable_hash = function() {
list(
http_interactions = self$interactions_to_record(),
recorded_with = utils::packageVersion("vcr")
)
},
#' @description Get the list of http interactions to record
#' @return list
interactions_to_record = function() {
## FIXME - gotta sort out defining and using hooks better
## just returning exact same input
self$merged_interactions()
# FIXME: not sure what's going on here, so not using yet
#. maybe we don't need this?
# "We dee-dupe the interactions by roundtripping them to/from a hash.
# This is necessary because `before_record` can mutate the interactions."
# lapply(self$merged_interactions(), function(z) {
# VCRHooks$invoke_hook("before_record", z)
# })
},
#' @description Get interactions to record
#' @return list
merged_interactions = function() {
old_interactions <- self$previously_recorded_interactions()
old_interactions <- lapply(old_interactions, function(x) {
HTTPInteraction$new(
request = x$request,
response = x$response,
recorded_at = x$recorded_at)
})
if (self$should_remove_matching_existing_interactions()) {
new_interaction_list <-
HTTPInteractionList$new(self$new_recorded_interactions,
self$match_requests_on)
old_interactions <-
Filter(function(x) {
req <- Request$new()$from_hash(x$request)
!unlist(new_interaction_list$has_interaction_matching(req))
},
old_interactions
)
}
return(c(self$up_to_date_interactions(old_interactions),
self$new_recorded_interactions))
},
#' @description Cleans out any old interactions based on the
#' re_record_interval and clean_outdated_http_interactions settings
#' @param interactions list of http interactions, of class [HTTPInteraction]
#' @return list of interactions to record
up_to_date_interactions = function(interactions) {
if (
!self$clean_outdated_http_interactions && is.null(self$re_record_interval)
) {
return(interactions)
}
Filter(function(z) {
as.POSIXct(z$recorded_at, tz = "GMT") > (as.POSIXct(Sys.time(), tz = "GMT") - self$re_record_interval)
}, interactions)
},
#' @description Should re-record interactions?
#' @return logical
should_re_record = function() {
if (is.null(self$re_record_interval)) return(FALSE)
if (is.null(self$originally_recorded_at())) return(FALSE)
now <- as.POSIXct(Sys.time(), tz = "GMT")
time_comp <- (self$originally_recorded_at() + self$re_record_interval) < now
info <- sprintf(
"previously recorded at: '%s'; now: '%s'; interval: %s seconds",
self$originally_recorded_at(), now, self$re_record_interval)
if (!time_comp) {
vcr_log_info(
sprintf("Not re-recording since the interval has not elapsed (%s).", info),
vcr_c$log_opts$date)
return(FALSE)
} else if (has_internet()) {
vcr_log_info(sprintf("re-recording (%s).", info), vcr_c$log_opts$date)
return(TRUE)
} else {
vcr_log_info(
sprintf("Not re-recording because no internet connection is available (%s).", info),
vcr_c$log_opts$date)
return(FALSE)
}
},
#' @description Is record mode NOT "all"?
#' @return logical
should_stub_requests = function() {
self$record != "all"
},
#' @description Is record mode "all"?
#' @return logical
should_remove_matching_existing_interactions = function() {
self$record == "all"
},
#' @description Get the serializer path
#' @return character
storage_key = function() self$serializer$path,
#' @description Get character string of entire cassette; bytes is a misnomer
#' @return character
raw_cassette_bytes = function() {
file <- self$file()
if (is.null(file)) return("")
tmp <- readLines(file) %||% ""
paste0(tmp, collapse = "")
},
#' @description Create the directory that holds the cassettes, if not present
#' @return no return; creates a directory recursively, if missing
make_dir = function() {
dir.create(path.expand(self$root_dir), showWarnings = FALSE,
recursive = TRUE)
},
#' @description get http interactions from the cassette via the serializer
#' @return list
deserialized_hash = function() {
tmp <- self$serializer$deserialize(self)
if (inherits(tmp, "list")) {
return(tmp)
} else {
stop(tmp, " does not appear to be a valid cassette", call. = FALSE)
}
},
#' @description get all previously recorded interactions
#' @return list
previously_recorded_interactions = function() {
if (nchar(self$raw_cassette_bytes()) > 0) {
tmp <- compact(
lapply(self$deserialized_hash()[["http_interactions"]], function(z) {
response <- VcrResponse$new(
z$response$status,
z$response$headers,
z$response$body$string %||% z$response$body$base64_string,
opts = self$cassette_opts,
disk = z$response$body$file
)
if (self$update_content_length_header)
response$update_content_length_header()
zz <- HTTPInteraction$new(
request = Request$new(z$request$method,
z$request$uri,
z$request$body$string,
z$request$headers,
disk = z$response$body$file),
response = response
)
hash <- zz$to_hash()
if (request_ignorer$should_be_ignored(hash$request)) NULL else hash
}))
return(tmp)
} else {
return(list())
}
},
#' @description write recorded interactions to disk
#' @return nothing returned
write_recorded_interactions_to_disk = function() {
if (!self$any_new_recorded_interactions()) return(NULL)
hash <- self$serializable_hash()
if (length(hash[["http_interactions"]]) == 0) return(NULL)
fun <- self$serializer$serialize()
fun(hash[[1]], self$persister$file_name, self$preserve_exact_body_bytes)
},
#' @description record an http interaction (doesn't write to disk)
#' @param x an crul or httr response object, with the request at `$request`
#' @return nothing returned
record_http_interaction = function(x) {
int <- self$make_http_interaction(x)
self$http_interactions_$response_for(int$request)
vcr_log_info(sprintf(" Recorded HTTP interaction: %s => %s",
request_summary(int$request), response_summary(int$response)),
vcr_c$log_opts$date)
self$new_recorded_interactions <- c(self$new_recorded_interactions, int)
},
#' @description Are there any new recorded interactions?
#' @return logical
any_new_recorded_interactions = function() {
length(self$new_recorded_interactions) != 0
},
#' @description make list of all options
#' @return nothing returned
make_args = function() {
self$args <- list(
record = self$record,
match_requests_on = self$match_requests_on,
re_record_interval = self$re_record_interval,
tag = self$tag, tags = self$tags,
update_content_length_header = self$update_content_length_header,
allow_playback_repeats = self$allow_playback_repeats,
allow_unused_http_interactions = self$allow_unused_http_interactions,
exclusive = self$exclusive, serialize_with = self$serialize_with,
persist_with = self$persist_with,
preserve_exact_body_bytes = self$preserve_exact_body_bytes
)
},
#' @description write metadata to the cassette
#' @return nothing returned
write_metadata = function() {
aa <- c(name = self$name, self$args)
for (i in seq_along(aa)) {
cat(sprintf("%s: %s", names(aa[i]), aa[i]),
file = sprintf("%s/%s_metadata.yml",
path.expand(cassette_path()), self$name),
sep = "\n", append = TRUE)
}
},
#' @description make [HTTPInteractionList] object, assign to http_interactions_ var
#' @return nothing returned
http_interactions = function() {
self$http_interactions_ <- HTTPInteractionList$new(
interactions = {
if (self$should_stub_requests()) {
self$previously_recorded_interactions()
} else {
list()
}
},
request_matchers = self$match_requests_on
# request_matchers = vcr_configuration()$match_requests_on
)
},
#' @description Make an `HTTPInteraction` object
#' @param x an crul or httr response object, with the request at `$request`
#' @return an object of class [HTTPInteraction]
make_http_interaction = function(x) {
# content must be raw or character
assert(unclass(x$content), c('raw', 'character'))
new_file_path <- ""
is_disk <- FALSE
if (is.character(x$content)) {
if (file.exists(x$content)) {
is_disk <- TRUE
write_disk_path <- vcr_c$write_disk_path
if (is.null(write_disk_path))
stop("if writing to disk, write_disk_path must be given; ",
"see ?vcr_configure")
new_file_path <- file.path(write_disk_path, basename(x$content))
}
}
request <- Request$new(
method = x$request$method,
uri = x$url,
body = if (inherits(x, "response")) { # httr
bd <- webmockr::pluck_body(x$request)
if (inherits(bd, "raw")) rawToChar(bd) else bd
} else { # crul
webmockr::pluck_body(x$request)
},
headers = if (inherits(x, "response")) {
as.list(x$request$headers)
} else {
x$request_headers
},
opts = self$cassette_opts,
disk = is_disk,
skip_port_stripping = TRUE
)
response <- VcrResponse$new(
status = if (inherits(x, "response")) {
c(list(status_code = x$status_code), httr::http_status(x))
} else unclass(x$status_http()),
headers = if (inherits(x, "response")) x$headers else x$response_headers,
body = if (is.raw(x$content)) {
if (can_rawToChar(x$content)) rawToChar(x$content) else x$content
} else {
stopifnot(inherits(unclass(x$content), "character"))
if (file.exists(x$content)) {
# calculate new file path in fixtures/
# copy file into fixtures/file_cache/
# don't move b/c don't want to screw up first use before using
# cached request
file.copy(x$content, write_disk_path,
overwrite = TRUE, recursive = TRUE) # copy the file
new_file_path
# raw(0)
} else {
x$content
}
},
http_version = if (inherits(x, "response")) {
x$all_headers[[1]]$version
} else {
x$response_headers$status
},
opts = self$cassette_opts,
disk = is_disk
)
if (self$update_content_length_header)
response$update_content_length_header()
HTTPInteraction$new(request = request, response = response)
},
#' @description Make a crul response object
#' @return a crul response
serialize_to_crul = function() {
if (length(self$deserialized_hash()) != 0) {
intr <- self$deserialized_hash()[[1]][[1]]
} else {
intr <- tryCatch(
self$previously_recorded_interactions()[[1]],
error = function(e) e
)
if (inherits(intr, "error")) {
intr <- tryCatch(
self$new_recorded_interactions[[1]],
error = function(e) e
)
if (inherits(intr, "error")) {
stop("no requests found to construct a crul response")
}
}
}
# request
req <- webmockr::RequestSignature$new(
method = intr$request$method,
uri = intr$request$uri,
options = list(
body = intr$request$body %||% NULL,
headers = intr$request$headers %||% NULL,
proxies = NULL,
auth = NULL
)
)
# response
resp <- webmockr::Response$new()
resp$set_url(intr$request$uri)
bod <- intr$response$body
resp$set_body(if ("string" %in% names(bod)) bod$string else bod)
resp$set_request_headers(intr$request$headers)
resp$set_response_headers(intr$response$headers)
resp$set_status(status = intr$response$status$status_code %||% 200)
# generate crul response
webmockr::build_crul_response(req, resp)
}
),
private = list(
remove_empty_cassette = function() {
if (!any(nzchar(readLines(self$file())))) {
unlink(self$file(), force = TRUE)
if (vcr_c$warn_on_empty_cassette)
warning(empty_cassette_message(self$name), call. = FALSE)
}
}
)
)
empty_cassette_message <- function(x) {
c(
sprintf("Empty cassette (%s) deleted; consider the following:\n", x),
" - If an error occurred resolve that first, then check:\n",
" - vcr only supports crul & httr; requests w/ curl, download.file, etc. are not supported\n",
" - If you are using crul/httr, are you sure you made an HTTP request?\n")
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.