Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
338 lines (305 sloc) 9.52 KB
#' Capture and record database transactions and save them as mocks
#'
#' When creating database fixtures, it can sometimes be helpful to see record
#' the responses from the database for use in crafting tests.
#'
#' You can start capturing with `start_db_capturing()` and end it with
#' `stop_db_capturing`. All queries run against a database will be executed like
#' normal, but their responses will be saved to the mock path given, so that if
#' you use the same queries later inside of a [`with_mock_db`] block, the
#' database functions will return as if they had been run against the database.
#'
#' You can redact certain columns using the `redact_columns` argument. This will
#' replace the values in the column with a generic redacted version. This works
#' by always passing the data being saved through [`redact_columns()`].
#'
#' _note_ You should always call [`DBI::dbConnect`] inside of the capturing
#' block. When you connect to the database, dittodb sets up the mocks for the
#' specific database you're connecting to when you call [`DBI::dbConnect`].
#'
#' `start_capturing()` and `stop_capturing()` do the exact same thing as
#' `start_db_capturing()` and `stop_db_capturing()`. They are both deprecated so
#' as not to clash with other packages when loaded.
#'
#' @param path the path to record mocks (default if missing: the first path in
#' `.db_mock_paths()`.
#' @param redact_columns a character vector of columns to redact. Any column
#' that matches an entry will be redacted with a standard value for the column
#' type (e.g. characters will be replaced with "\[redacted\]")
#'
#' @return NULL (invisibily)
#'
#' @examples
#' \dontrun{
#' start_db_capturing()
#' con <- dbConnect(RSQLite::SQLite(), "memory")
#'
#' df_1 <- dbGetQuery(con, "SELECT * FROM rpostgresql.airlines LIMIT 1")
#' res <- dbSendQuery(con, "SELECT * FROM rpostgresql.airlines LIMIT 2")
#' df_2 <- dbFetch(res)
#'
#' dbDisconnect(con)
#' stop_db_capturing()
#'
#' start_db_capturing(redact_columns = "carrier")
#' con <- dbConnect(RSQLite::SQLite(), "memory")
#'
#' df_1 <- dbGetQuery(con, "SELECT * FROM rpostgresql.airlines LIMIT 3")
#'
#' dbDisconnect(con)
#' stop_db_capturing()
#' }
#' @name capture_requests
NULL
# borrowed from httptest
safe_untrace <- function(what, where = sys.frame()) {
## If you attempt to untrace a function (1) that isn't exported from
## whatever namespace it lives in and (2) that isn't currently traced,
## it errors. This prevents that so that it's always safe to call `untrace`
## untrace() and get() handle enviroments differently
if (is.environment(where)) {
env <- where
} else {
env <- environment(where)
}
if (inherits(
try(get(what, env), silent = TRUE),
c("functionWithTrace", "standardGenericWithTrace")
)) {
quietly(untrace(what, where = where))
}
}
# borrowed from httptest
quietly <- function(expr) {
env <- parent.frame()
if (dittodb_debug_level(2)) {
eval(expr, env)
} else {
suppressMessages(eval(expr, env))
}
}
# borrowed from httptest
trace_dbi <- function(...,
where_list = list(sys.frame(), asNamespace("DBI")),
print = dittodb_debug_level(2)) {
for (place in where_list) {
quietly(trace(..., print = print, where = place))
}
}
connection_list <- c(
"MariaDBConnection",
"PostgreSQLConnection",
"PqConnection",
"SQLiteConnection",
"OdbcConnection"
)
# for detecting if a particular method has been loaded
method_loaded <- Vectorize(function(method, signature) {
return(any(grepl(signature, methods(method))))
}, vectorize.args = "signature")
#' @rdname capture_requests
#' @export
start_db_capturing <- function(path, redact_columns = NULL) {
if (!missing(path)) {
## Note that this changes state and doesn't reset it
.db_mock_paths(path)
}
set_redactor(redact_columns)
quietly(trace_dbi(
"dbConnect",
exit = quote({
.dittodb_env$db_path <- file.path(
.db_mock_paths()[1],
get_dbname(list(...))
)
dir.create(.dittodb_env$db_path, showWarnings = FALSE, recursive = TRUE)
})
))
quietly(trace_dbi(
"dbSendQuery",
exit = quote({
if (dittodb_debug_level(1)) {
message(
"The statement: \n", statement,
"\nis being hased to: ", hash(statement)
)
}
.dittodb_env$curr_file_path <- make_path(
.dittodb_env$db_path,
get_type(statement),
hash(statement)
)
})
))
#' @export
#' @keywords internal
recordFetch <- quote({
if (dittodb_debug_level(1)) {
message("Writing to ", .dittodb_env$curr_file_path)
}
out <- redact_columns(ans, columns = get_redactor())
dput(out, .dittodb_env$curr_file_path, control = c("all", "hexNumeric"))
})
quietly(trace_dbi(
"dbFetch",
exit = recordFetch
))
quietly(trace_dbi(
"fetch",
exit = recordFetch
))
quietly(trace_dbi(
"dbListTables",
exit = quote({
thing <- returnValue()
dput(
thing,
file.path(.dittodb_env$db_path, "dbListTables.R"),
control = c("all", "hexNumeric")
)
})
))
quietly(trace_dbi(
"dbListFields",
exit = quote({
thing <- returnValue()
name <- sanitize_table_id(name, ...)
dput(
thing,
file.path(.dittodb_env$db_path, glue("dbListFields-{name}.R")),
control = c("all", "hexNumeric")
)
})
))
quietly(trace_dbi(
"dbColumnInfo",
exit = quote({
thing <- returnValue()
# TODO: would this be better if we traced the methods using signature?
if (inherits(res, "PostgreSQLResult")) {
result_info <- RPostgreSQL::postgresqlResultInfo(res)
hash <- hash(result_info$statement)
} else if (inherits(res, c("MariaDBResult", "PqResult"))) {
hash <- hash(res@sql)
} else if (inherits(res, "OdbcResult")) {
hash <- hash(res@statement)
} else {
# TODO: some default?
}
path <- make_path(.dittodb_env$db_path, "columnInfo", hash)
dput(thing, path, control = c("all", "hexNumeric"))
})
))
# TODO: for RPostgreSQL to work, we need to prevent RPostgreSQL's
# `postgresqlCloseConnection` from calling `dbListResults` which over-writes
# our fixture
# each connection has to be mocked separately because there's no
# DBI::dbGetInfo for DBIConnection
for (conn in connection_list) {
if (method_loaded("dbGetInfo", conn)) {
quietly(trace_dbi(
"dbGetInfo",
signature = conn,
exit = quote({
thing <- returnValue()
path <- make_path(.dittodb_env$db_path, "conInfo", "")
if (length(path) > 0) {
# generally .dittodb_env$db_path is not-null, but RPostgreSQL uses
# dbGetInfo in the connection process, don't record mocks then.
dput(thing, path, control = c("all", "hexNumeric"))
}
})
))
}
}
quietly(trace_dbi(
"dbGetInfo",
signature = "DBIResult",
exit = quote({
thing <- returnValue()
# TODO: would this be better if we traced the methods individually?
if (inherits(dbObj, c("MariaDBResult", "PqResult"))) {
hash <- hash(dbObj@sql)
} else if (inherits(dbObj, "OdbcResult")) {
hash <- hash(dbObj@statement)
} else {
# TODO: some default?
}
path <- make_path(.dittodb_env$db_path, "resultInfo", hash)
dput(thing, path, control = c("all", "hexNumeric"))
})
))
if (method_loaded("dbGetInfo", "PostgreSQLResult")) {
quietly(trace_dbi(
"dbGetInfo",
signature = "PostgreSQLResult",
exit = quote({
thing <- returnValue()
result_info <- RPostgreSQL::postgresqlResultInfo(dbObj)
hash <- hash(result_info$statement)
path <- make_path(.dittodb_env$db_path, "resultInfo", hash)
if (length(path) > 0) {
# generally .dittodb_env$db_path is not-null, but RPostgreSQL uses
# dbGetInfo in the connection process, don't record mocks then.
dput(thing, path, control = c("all", "hexNumeric"))
}
})
))
}
return(invisible(NULL))
}
# for backwards compatibility
#' @rdname capture_requests
#' @export
#' @keywords internal
start_capturing <- start_db_capturing
#' an environment for dittodb storing state
#'
#' @export
#' @keywords internal
.dittodb_env <- new.env(parent = emptyenv())
#' @rdname capture_requests
#' @export
stop_db_capturing <- function() {
for (func in c(
"dbSendQuery", "dbFetch", "dbConnect", "fetch", "dbListTables",
"dbListFields", "dbColumnInfo", "dbGetInfo")) {
# make sure we untrace the function:
# * from the DBI namespace
# * from the DBI environment
# * as it is seen by the user (default for safe_untrace)
safe_untrace(func, asNamespace("DBI"))
safe_untrace(func, "DBI")
safe_untrace(func)
}
remove_redactor()
}
# for backwards compatibility
#' @rdname capture_requests
#' @export
#' @keywords internal
stop_capturing <- stop_db_capturing
set_redactor <- function(redactors) {
.dittodb_env$redactor <- redactors
return(invisible(redactors))
}
remove_redactor <- function() {
if (exists("redactor", envir = .dittodb_env)) {
rm("redactor", envir = .dittodb_env)
}
return(invisible(NULL))
}
#' Get the current redactor
#'
#' This function should generally not be used, but must be exported for the
#' query recording function to work properly
#'
#' @return the current list of columns to redact
#' @export
#' @keywords internal
get_redactor <- function() {
if (exists("redactor", envir = .dittodb_env)) {
return(get("redactor", envir = .dittodb_env))
}
return(NULL)
}
You can’t perform that action at this time.