diff --git a/DESCRIPTION b/DESCRIPTION index 8e08556..e4b5078 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: flipAPI Type: Package Title: Web APIs tools -Version: 1.6.0 +Version: 1.6.5 Author: Displayr Maintainer: Displayr Description: Functions to extract data and interact with web APIs. @@ -23,7 +23,6 @@ Imports: stringr, readxl, utils, - flipFormat, flipTime, flipTransformations, flipU (>= 1.6.1), @@ -48,4 +47,4 @@ Suggests: httptest, officer, gifski -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 diff --git a/R/DataMart.R b/R/DataMart.R index 6aed9f9..6cb7bf0 100644 --- a/R/DataMart.R +++ b/R/DataMart.R @@ -8,6 +8,8 @@ MAX.FILENAME.LENGTH <- 100L #' To reference a file in a subdirectory, use double backslashes after each folder (e.g "subdir\\file.csv"). #' @param show.warning logical scalar. Whether to show a warning when the file #' does not exist. +#' @param company.token Use this if you need to access a different company's Displayr Cloud Drive. You need to contact Support to get this token. +#' @param document.token Reserved. #' #' @return TRUE if the file exists, otherwise FALSE. #' @@ -15,13 +17,15 @@ MAX.FILENAME.LENGTH <- 100L #' @importFrom utils URLencode #' #' @export -QFileExists <- function(filename, show.warning = TRUE) +QFileExists <- function(filename, show.warning = TRUE, company.token = NA, document.token = NA) { - company.secret <- getCompanySecret() + company.secret <- if (missing(company.token)) getCompanySecret() else company.token + project.secret <- if (missing(document.token)) getProjectSecret() else document.token client.id <- getClientId() api.root <- getApiRoot("DataMartFileExists") res <- try(GET(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config=add_headers("X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id))) if (is.null(res$status_code) || res$status_code != 200) @@ -54,6 +58,7 @@ QFileExists <- function(filename, show.warning = TRUE) #' @param method character string. See documentation for connections. #' @param mime.type character string. The mime-type of this file. If not provided, it will be interpreted from the file extension. #' @param company.token Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token. +#' @inheritParams QFileExists #' #' @return A curl connection (read) or a file connection (write) #' @@ -66,17 +71,20 @@ QFileExists <- function(filename, show.warning = TRUE) QFileOpen <- function(filename, open = "r", blocking = TRUE, encoding = getOption("encoding"), raw = FALSE, method = getOption("url.method", "default"), - mime.type = NA, company.token = NA) + mime.type = NA, company.token = NA, document.token = NA) { mode <- tolower(open) + company.secret <- if (missing(company.token)) getCompanySecret() else company.token + project.secret <- if (missing(document.token)) getProjectSecret() else document.token + if (mode == "r" || mode == "rb") { - company.secret <- if (missing(company.token)) getCompanySecret() else company.token client.id <- getClientId() api.root <- getApiRoot() h <- new_handle() handle_setheaders(h, "X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id ) uri <- paste0(api.root, "?filename=", URLencode(filename, TRUE)) @@ -116,6 +124,8 @@ QFileOpen <- function(filename, open = "r", blocking = TRUE, attr(con, "filename") <- filename if (missing(mime.type)) mime.type <- guess_type(filename) attr(con, "mimetype") <- mime.type + attr(con, "company.secret") <- company.secret + attr(con, "project.secret") <- project.secret return (con) } @@ -146,14 +156,16 @@ close.qpostcon = function(con, ...) filename <- attr(con, "filename") tmpfile <- attr(con, "tmpfile") mimetype <- attr(con, "mimetype") + company.secret <- attr(con, "company.secret") + project.secret <- attr(con, "project.secret") on.exit(if(file.exists(tmpfile)) file.remove(tmpfile)) - company.secret <- getCompanySecret() client.id <- getClientId() api.root <- getApiRoot() res <- try(POST(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config = add_headers("Content-Type" = mimetype, "X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id), encode = "raw", body = upload_file(tmpfile))) @@ -178,6 +190,7 @@ close.qpostcon = function(con, ...) #' @param filename character string. Name of the file to be opened from the Displayr Cloud Drive. #' To reference a file in a subdirectory, use double backslashes after each folder (e.g "subdir\\file.csv"). #' @param company.token Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token. +#' @inheritParams QFileExists #' @param ... Other parameters to pass to read.csv. #' #' @return An R object @@ -189,14 +202,16 @@ close.qpostcon = function(con, ...) #' @importFrom flipU StopForUserError #' #' @export -QLoadData <- function(filename, company.token = NA, ...) +QLoadData <- function(filename, company.token = NA, document.token = NA,...) { tmpfile <- tempfile() company.secret <- if (missing(company.token)) getCompanySecret() else company.token + project.secret <- if (missing(document.token)) getProjectSecret() else document.token client.id <- getClientId() api.root <- getApiRoot() res <- try(GET(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config=add_headers("X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id), write_disk(tmpfile, overwrite = TRUE))) @@ -253,7 +268,7 @@ QLoadData <- function(filename, company.token = NA, ...) #' (in bytes) larger than this value will be compressed into a zip file. #' Defaults to NULL, in which case no compression occurs. #' @param ... Other parameters to pass to \code{\link{write.csv}}, \code{\link{saveRDS}}, -#' \code{\link{write.xlsx}}, or \code{\link{write_sav}}. +#' \code{\link[openxlsx]{write.xlsx}}, or \code{\link[haven]{write_sav}}. #' #' @importFrom haven write_sav #' @importFrom httr POST add_headers upload_file @@ -317,11 +332,13 @@ QSaveData <- function(object, filename, compression.file.size.threshold = NULL, on.exit(if(file.exists(tmpfile)) file.remove(tmpfile)) company.secret <- getCompanySecret() + project.secret <- getProjectSecret() client.id <- getClientId() api.root <- getApiRoot() res <- try(POST(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config = add_headers("Content-Type" = guess_type(filename), "X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id), encode = "raw", body = upload_file(tmpfile))) @@ -368,7 +385,8 @@ QSaveData <- function(object, filename, compression.file.size.threshold = NULL, #' #' @param filenames collection of character strings. Names of the files to delete. #' To reference a file in a subdirectory, use double backslashes after each folder (e.g "subdir\\file.csv"). -#' @param company.token Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token. +#' @param company.token Use this if you need to delete files from a different company's Displayr Cloud Drive. You need to contact Support to get this token. +#' @inheritParams QFileExists #' #' @importFrom httr DELETE add_headers #' @importFrom utils URLencode @@ -377,14 +395,15 @@ QSaveData <- function(object, filename, compression.file.size.threshold = NULL, #' and assumed to succeed if no errors are thrown. #' #' @export -QDeleteFiles <- function(filenames, company.token = getCompanySecret()) +QDeleteFiles <- function(filenames, company.token = getCompanySecret(), document.token = getProjectSecret()) { company.secret <- company.token api.root <- getApiRoot("DataMartBatchDelete") url_param_filenames <- sprintf("filenames=%s", filenames) filenames.string <- paste(filenames, collapse = ", ") res <- try(DELETE(paste0(api.root, "?", URLencode(paste(url_param_filenames, collapse="&"))), - config=add_headers("X-Q-Company-Secret" = company.secret))) + config=add_headers("X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = document.token))) if (inherits(res, "try-error") || res$status_code != 200) { warning("Encountered an error deleting the following files: ", filenames.string) @@ -406,11 +425,13 @@ qSaveImage <- function(filename) on.exit(if(file.exists(tmpfile)) file.remove(tmpfile)) company.secret <- getCompanySecret() + project.secret <- getProjectSecret() client.id <- getClientId() api.root <- getApiRoot() res <- try(POST(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config = add_headers("Content-Type" = guess_type(filename), "X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id), encode = "raw", body = upload_file(tmpfile))) @@ -431,14 +452,16 @@ qSaveImage <- function(filename) invisible() } -qLoadImage <- function(filename, company.token = NA) +qLoadImage <- function(filename, company.token = NA, document.token = NA) { tmpfile <- tempfile() company.secret <- if (missing(company.token)) getCompanySecret() else company.token + project.secret <- if (missing(document.token)) getProjectSecret() else document.token client.id <- getClientId() api.root <- getApiRoot() res <- try(GET(paste0(api.root, "?filename=", URLencode(filename, TRUE)), config=add_headers("X-Q-Company-Secret" = company.secret, + "X-Q-Project-Secret" = project.secret, "X-Q-Project-ID" = client.id), write_disk(tmpfile, overwrite = TRUE))) @@ -484,6 +507,20 @@ getCompanySecret <- function() return (secret) } +#' Gets document secret from the environment or an empty string if not found. +#' +#' @return Document secret token as a string. +#' +#' @noRd +getProjectSecret <- function() +{ + get0("projectSecret", ifnotfound = NULL) %||% + # projectSecret might not have been copied into global projectSecret by an older R Server, + # but it could have been stored by QServer in user secrets which are copied into userSecrets by older R servers. + get0("userSecrets", mode = "list", ifnotfound = NULL)[["projectSecret"]] %||% + "" +} + #' Gets region from the environment and builds the api root. Throws an error if not found. #' #' @return Region-specific api root as a string. diff --git a/man/QDeleteFiles.Rd b/man/QDeleteFiles.Rd index 5cb4a57..2e0f725 100644 --- a/man/QDeleteFiles.Rd +++ b/man/QDeleteFiles.Rd @@ -4,13 +4,19 @@ \alias{QDeleteFiles} \title{Deletes a set of objects} \usage{ -QDeleteFiles(filenames, company.token = getCompanySecret()) +QDeleteFiles( + filenames, + company.token = getCompanySecret(), + document.token = getProjectSecret() +) } \arguments{ \item{filenames}{collection of character strings. Names of the files to delete. To reference a file in a subdirectory, use double backslashes after each folder (e.g "subdir\\file.csv").} -\item{company.token}{Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token.} +\item{company.token}{Use this if you need to delete files from a different company's Displayr Cloud Drive. You need to contact Support to get this token.} + +\item{document.token}{Reserved.} } \value{ NULL invisibly. Called for the purpose of deleting data diff --git a/man/QFileExists.Rd b/man/QFileExists.Rd index f25fbca..a87aab2 100644 --- a/man/QFileExists.Rd +++ b/man/QFileExists.Rd @@ -4,7 +4,12 @@ \alias{QFileExists} \title{Check if a file exists} \usage{ -QFileExists(filename, show.warning = TRUE) +QFileExists( + filename, + show.warning = TRUE, + company.token = NA, + document.token = NA +) } \arguments{ \item{filename}{character string. Name of the file to search for. @@ -12,6 +17,10 @@ To reference a file in a subdirectory, use double backslashes after each folder \item{show.warning}{logical scalar. Whether to show a warning when the file does not exist.} + +\item{company.token}{Use this if you need to access a different company's Displayr Cloud Drive. You need to contact Support to get this token.} + +\item{document.token}{Reserved.} } \value{ TRUE if the file exists, otherwise FALSE. diff --git a/man/QFileOpen.Rd b/man/QFileOpen.Rd index 2a7e204..9f5c49e 100644 --- a/man/QFileOpen.Rd +++ b/man/QFileOpen.Rd @@ -12,7 +12,8 @@ QFileOpen( raw = FALSE, method = getOption("url.method", "default"), mime.type = NA, - company.token = NA + company.token = NA, + document.token = NA ) } \arguments{ @@ -32,6 +33,8 @@ To reference a file in a subdirectory, use double backslashes after each folder \item{mime.type}{character string. The mime-type of this file. If not provided, it will be interpreted from the file extension.} \item{company.token}{Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token.} + +\item{document.token}{Reserved.} } \value{ A curl connection (read) or a file connection (write) diff --git a/man/QLoadData.Rd b/man/QLoadData.Rd index de4a880..2803509 100644 --- a/man/QLoadData.Rd +++ b/man/QLoadData.Rd @@ -4,7 +4,7 @@ \alias{QLoadData} \title{Loads an object} \usage{ -QLoadData(filename, company.token = NA, ...) +QLoadData(filename, company.token = NA, document.token = NA, ...) } \arguments{ \item{filename}{character string. Name of the file to be opened from the Displayr Cloud Drive. @@ -12,6 +12,8 @@ To reference a file in a subdirectory, use double backslashes after each folder \item{company.token}{Use this if you need to read from a different company's Displayr Cloud Drive. You need to contact Support to get this token.} +\item{document.token}{Reserved.} + \item{...}{Other parameters to pass to read.csv.} } \value{ diff --git a/man/QSaveData.Rd b/man/QSaveData.Rd index 026dd36..92ab3be 100644 --- a/man/QSaveData.Rd +++ b/man/QSaveData.Rd @@ -17,7 +17,7 @@ To reference a file in a subdirectory, use double backslashes after each folder Defaults to NULL, in which case no compression occurs.} \item{...}{Other parameters to pass to \code{\link{write.csv}}, \code{\link{saveRDS}}, -\code{\link{write.xlsx}}, or \code{\link{write_sav}}.} +\code{\link[openxlsx]{write.xlsx}}, or \code{\link[haven]{write_sav}}.} } \value{ NULL invisibly. Called for the purpose of uploading data diff --git a/tests/testthat/helper-datamart.R b/tests/testthat/helper-datamart.R index 12e8844..1b84c0f 100644 --- a/tests/testthat/helper-datamart.R +++ b/tests/testthat/helper-datamart.R @@ -1,6 +1,18 @@ companySecret <- get0("companySecret", ifnotfound = Sys.getenv("companySecret")) assign("companySecret", companySecret, envir = .GlobalEnv) +projectSecret <- "" +assign("projectSecret", projectSecret, envir = .GlobalEnv) clientId <- "-1027046" # This could be anything - we are just using this for metadata assign("clientId", clientId, envir = .GlobalEnv) region <- "app" assign("region", region, envir = .GlobalEnv) + +localGlobal <- function(name, value, envir = parent.frame()) { + if (exists(name, envir = .GlobalEnv)) { + old.value <- get(name, envir = .GlobalEnv) + withr::defer(assign(name, old.value, envir = .GlobalEnv), envir = envir) + } else { + withr::defer(rm(list = name, envir = .GlobalEnv), envir = envir) + } + assign(name, value, envir = .GlobalEnv) +} \ No newline at end of file diff --git a/tests/testthat/test-datamart-secrets.R b/tests/testthat/test-datamart-secrets.R new file mode 100644 index 0000000..787d99e --- /dev/null +++ b/tests/testthat/test-datamart-secrets.R @@ -0,0 +1,201 @@ +localGlobal("companySecret", "test_company_secret") +localGlobal("projectSecret", "test_project_secret") + +test_env = new.env() # holds HTTP header verification result that is put there by mocked HTTP function and is used by the tests below + +verifyHttpHeaders <- function(headers = character(0), expect_company_secret_header_to_be_equivalent_to_company_secret, expect_project_secret_header_to_be_equivalent_to_project_secret) +{ + companySecretHeader = headers[["X-Q-Company-Secret"]] %||% "" + projectSecretHeader = headers[["X-Q-Project-Secret"]] %||% "" + httpResponse <- structure(list(status_code = 200, content = "mock"), class = "response") + companySecret <- getCompanySecret() + projectSecret <- getProjectSecret() + + test_env$company_secret_header <- companySecretHeader + test_env$company_secret <- companySecret + test_env$project_secret_header <- projectSecretHeader + test_env$project_secret <- projectSecret + + companySecretHeaderIsValid <- TRUE + projectSecretHeaderIsValid <- TRUE + errors <- character() + + if (expect_company_secret_header_to_be_equivalent_to_company_secret && !identical(companySecretHeader, companySecret)) { + companySecretHeaderIsValid <- FALSE + errors <- append(errors, paste0("Expected 'companySecretHeader' ('", companySecretHeader, "') to equal 'companySecret' ('", companySecret, "')")) + } + + if (!expect_company_secret_header_to_be_equivalent_to_company_secret && identical(companySecretHeader, companySecret)) { + companySecretHeaderIsValid <- FALSE + errors <- append(errors, paste0("Expected 'companySecretHeader' ('", companySecretHeader, "') to not equal 'companySecret' ('", companySecret, "')")) + } + + if (expect_project_secret_header_to_be_equivalent_to_project_secret && !identical(projectSecretHeader, projectSecret)) { + projectSecretHeaderIsValid <- FALSE + errors <- append(errors, paste0("Expected 'projectSecretHeader' ('", projectSecretHeader, "') to equal 'projectSecret' ('", projectSecret, "')")) + } + + if (!expect_project_secret_header_to_be_equivalent_to_project_secret && identical(projectSecretHeader, projectSecret)) { + projectSecretHeaderIsValid <- FALSE + errors <- append(errors, paste0("Expected 'projectSecretHeader' ('", projectSecretHeader, "') to not equal 'projectSecret' ('", projectSecret, "')")) + } + + test_env$headersVerificationResult <- list(asExpected = companySecretHeaderIsValid && projectSecretHeaderIsValid, messages = errors) + return(httpResponse) +} + +expect_successful_headers_verification <- function() { + if (!test_env$headersVerificationResult$asExpected) { + fail(test_env$headersVerificationResult$messages) + } else { + expect_true(TRUE) + } +} + +params <- list( + list(company.token = NA, document.token = NA, + expect_company_secret_header_to_be_equivalent_to_company_secret = TRUE, + expect_project_secret_header_to_be_equivalent_to_project_secret = TRUE, + description = "neither company.token no document.token are provided (NA)"), + + list(company.token = "some_token", document.token = "some_project_token", + expect_company_secret_header_to_be_equivalent_to_company_secret = FALSE, + expect_project_secret_header_to_be_equivalent_to_project_secret = FALSE, + description = "company.token is 'some_token'; document.token is 'some_project_token'"), + + list(company.token = "test_company_secret", document.token = "test_project_secret", + expect_company_secret_header_to_be_equivalent_to_company_secret = TRUE, + expect_project_secret_header_to_be_equivalent_to_project_secret = TRUE, + description = "company.token is the same as companySecret; document.token is the same as projectSecret") +) + +for (p in params){ + companyTokenParameter = ifelse(is.na(p$company.token), getCompanySecret(), p$company.token) # p$company.token == NA simulates missing company.token parameter + documentTokenParameter = ifelse(is.na(p$document.token), getProjectSecret(), p$document.token) # p$document.token == NA simulates missing document.token parameter + clientId <- "1" + + mockedHTTPRequest <- function(url = NULL, config = list(), ...) { + verifyHttpHeaders(config$headers, p$expect_company_secret_header_to_be_equivalent_to_company_secret, p$expect_project_secret_header_to_be_equivalent_to_project_secret) + } + + mockedCloseConnection <- function(con) { } + + mockedFileExists <- function(filename) { return(FALSE) } + + mockedCurl <- function(url, open, handle) { + structure(list(url = "http://test/api/DataMart"), class = "connection") + } + + test_that(paste0("QFileExists correctly passes companySecret and company.token in HTTP header when ", p$description), + { + test_env$headersVerificationResult <- NULL + + with_mocked_bindings( + code = { + args <- list(filename = "Test.dat", show.warning = FALSE) + if (!is.na(companyTokenParameter)) { + args$company.token <- companyTokenParameter + } + if (!is.na(documentTokenParameter)) { + args$document.token <- documentTokenParameter + } + result <- do.call(QFileExists, args) + + expect_successful_headers_verification() + expect_true(result, info = "QFileExists should return TRUE with mocked GET.") + }, + GET = mockedHTTPRequest, + ##.package = "flipAPI" + ) + }) + + test_that(paste0("close.qpostcon correctly passes companySecret and company.token in HTTP header when ", p$description), + { + test_env$headersVerificationResult <- NULL + + orig_close_connection <- close.connection + orig_file_exists <- file.exists + on.exit({ + close.connection <- orig_close_connection + file.exists <- orig_file_exists + }, add = TRUE) + close.connection <- NULL # this is needed to ensure a binding for the function exists in this package's namespace before mocking + file.exists <- NULL + + with_mocked_bindings( + code = { + with_mocked_bindings( + code = { + con <- structure(list(url = "http://test/api/DataMart"), class = "connection") + # close.qpostcon does not directly accept token parameters, but uses values that were stored with the connection by QFileOpen + attr(con, "company.secret") <- companyTokenParameter + attr(con, "project.secret") <- documentTokenParameter + + close.qpostcon(con) + + expect_successful_headers_verification() + }, + close.connection = mockedCloseConnection, + file.exists = mockedFileExists, + .package = "base" + ) + }, + POST = mockedHTTPRequest + ) + }) + + test_that(paste0("QDeleteFiles correctly passes companySecret and company.token in HTTP header when ", p$description), + { + test_env$headersVerificationResult <- NULL + + with_mocked_bindings( + code = { + args <- list(c("Test1.dat", "Test2.dat")) + if (!is.na(companyTokenParameter)) args$company.token <- companyTokenParameter + if (!is.na(documentTokenParameter)) args$document.token <- documentTokenParameter + + do.call(QDeleteFiles, args) + + expect_successful_headers_verification() + }, + DELETE = mockedHTTPRequest, + .package = "flipAPI" + ) + }) +} + +test_that("getProjectSecret correctly extracts project secret from environment", +{ + projectSecretValueName <- "projectSecret" + userSecretsValueName <- "userSecrets" + testProjectSecretValue <- "test_project_secret" + projectSecretValueInUserSecrets <- paste0(testProjectSecretValue, "_from_user_secrets") + + # Case #1: projectSecret is set in environment in projectSecret + { + localGlobal(projectSecretValueName, testProjectSecretValue) + expect_equal(getProjectSecret(), testProjectSecretValue) + } + + # Case #2: projectSecret is not set in environment in projectSecret, but is set in environment in userSecrets$projectSecret + { + userSecretsValue <- list(projectSecret = testProjectSecretValue) + localGlobal(userSecretsValueName, userSecretsValue) + expect_equal(getProjectSecret(), testProjectSecretValue) + } + + # Case #3: projectSecret is set in both places, getProjectSecret() should prefer projectSecret + { + localGlobal(projectSecretValueName, testProjectSecretValue) + userSecretsValue <- list(projectSecret = testProjectSecretValue) + localGlobal(userSecretsValueName, userSecretsValue) + expect_equal(getProjectSecret(), testProjectSecretValue) + } + + # Case #4: projectSecret is not set in either place + { + rm(list = projectSecretValueName, envir = .GlobalEnv) + rm(list = userSecretsValueName, envir = .GlobalEnv) + expect_equal(getProjectSecret(), "", info = "Case #4") + } +})