Use included SQL files instead of those included in etn

R/connect_to_etn.R

@@ -19,11 +19,28 @@
 #' con <- connect_to_etn(username = "my_username", password = "my_password")
 #' }
 connect_to_etn <- function(username, password) {
- connection <- DBI::dbConnect(
- odbc::odbc(),
- "ETN",
- uid = paste("", tolower(username), "", sep = ""),
- pwd = paste("", password, "", sep = "")
+ tryCatch(
+ {
+ # Attempt to connect to the database with the provided credentials
+ connection <- DBI::dbConnect(
+ odbc::odbc(),
+ "ETN",
+ uid = paste("", tolower(username), "", sep = ""),
+ pwd = paste("", password, "", sep = "")
+ )
+ return(connection)
+ },
+ error = function(e) {
+ # When the database connection fails, return the error message and some
+ # directions to try again. This is usually due to a wrong password, so
+ # let's include that as a clue in the error message.
+ stop(glue::glue(e$message,
+ "Failed to connect to the database.",
+ "Did you enter the right username/password?",
+ "Please try again.",
+ .sep = "\n"),
+ call. = FALSE)
+
+ }
  )
- return(connection)
 }

R/get_acoustic_deployments.R

@@ -52,6 +52,9 @@ get_acoustic_deployments <- function(
  station_name = NULL,
  open_only = FALSE) {
 
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # create connection object
  connection <-
  connect_to_etn(credentials$username, credentials$password)

R/get_acoustic_detections.R

@@ -90,6 +90,8 @@ get_acoustic_detections <- function(credentials = list(
  station_name = NULL,
  limit = FALSE) {
 
+ # Check if credentials object has right shape
+ check_credentials(credentials)
 
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
@@ -215,7 +217,7 @@ get_acoustic_detections <- function(credentials = list(
  }
 
  acoustic_tag_id_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")),
+ readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_acoustic_projects.R

@@ -29,6 +29,10 @@ get_acoustic_projects <- function(credentials = list(
  password = Sys.getenv("pwd")
  ),
  acoustic_project_code = NULL) {
+
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # create connection object
  connection <-
  connect_to_etn(credentials$username, credentials$password)
@@ -53,7 +57,7 @@ get_acoustic_projects <- function(credentials = list(
  }
 
  project_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_acoustic_receivers.R

@@ -66,11 +66,11 @@ get_acoustic_receivers <- function(credentials = list(
  }
 
  receiver_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "receiver.sql", package = "etn")),
+ readr::read_file(system.file("sql", "receiver.sql", package = "etnservice")),
  .con = connection
  )
  acoustic_tag_id_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")),
+ readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_animal_projects.R

@@ -29,6 +29,10 @@ get_animal_projects <- function(credentials = list(
  password = Sys.getenv("pwd")
  ),
  animal_project_code = NULL) {
+
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
 
@@ -52,7 +56,7 @@ get_animal_projects <- function(credentials = list(
  }
 
  project_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_animals.R

@@ -52,6 +52,10 @@ get_animals <- function(credentials = list(
  tag_serial_number = NULL,
  animal_project_code = NULL,
  scientific_name = NULL) {
+
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
 
@@ -121,7 +125,7 @@ get_animals <- function(credentials = list(
  }
 
  tag_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "tag.sql", package = "etn")),
+ readr::read_file(system.file("sql", "tag.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_cpod_projects.R

@@ -29,6 +29,10 @@ get_cpod_projects <- function(credentials = list(
  password = Sys.getenv("pwd")
  ),
  cpod_project_code = NULL) {
+
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
 
@@ -52,7 +56,7 @@ get_cpod_projects <- function(credentials = list(
  }
 
  project_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
 

R/get_tags.R

@@ -49,6 +49,9 @@ get_tags <- function(credentials = list(
  tag_serial_number = NULL,
  acoustic_tag_id = NULL) {
 
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
 
@@ -116,7 +119,7 @@ get_tags <- function(credentials = list(
  }
 
  tag_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "tag.sql", package = "etn")),
+ readr::read_file(system.file("sql", "tag.sql", package = "etnservice")),
  .con = connection
  )
 

R/list_acoustic_project_codes.R

@@ -13,7 +13,7 @@ list_acoustic_project_codes <- function(credentials = list(
  connection <- connect_to_etn(credentials$username, credentials$password)
 
  project_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
  query <- glue::glue_sql(

R/list_acoustic_tag_ids.R

@@ -11,7 +11,7 @@ list_acoustic_tag_ids <- function(credentials = list(
 )) {
  connection <- connect_to_etn(credentials$username, credentials$password)
  acoustic_tag_id_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etn")),
+ readr::read_file(system.file("sql", "acoustic_tag_id.sql", package = "etnservice")),
  .con = connection
  )
  query <- glue::glue_sql("

R/list_animal_project_codes.R

@@ -13,7 +13,7 @@ list_animal_project_codes <- function(credentials = list(
  connection <- connect_to_etn(credentials$username, credentials$password)
 
  project_sql <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
  query <- glue::glue_sql(

R/list_cpod_project_codes.R

@@ -11,14 +11,17 @@ list_cpod_project_codes <- function(credentials = list(
  password = Sys.getenv("pwd")
 )) {
 
+ # Check if credentials object has right shape
+ check_credentials(credentials)
+
  # Create connection object
  connection <- connect_to_etn(credentials$username, credentials$password)
 
  # Check if we can make a connection
  check_connection(connection)
 
  project_query <- glue::glue_sql(
- readr::read_file(system.file("sql", "project.sql", package = "etn")),
+ readr::read_file(system.file("sql", "project.sql", package = "etnservice")),
  .con = connection
  )
  query <- glue::glue_sql(

R/utils.R

@@ -110,6 +110,47 @@ get_credentials <-
  stringr::str_glue('list(username = "{username}", password = "{password}")')
  }
 
+#' Check if the provided credentials are valid.
+#'
+#' This function checks if the provided credentials contain a "username" and "password" field,
+#' and if both fields are of type character. It also verifies that the credentials object has a length of 2.
+#'
+#' @param credentials A list or data frame containing the credentials to be checked.
+#'
+#' @return TRUE if the credentials are valid, an error otherwise
+#'
+#' @examples
+#' credentials <- list(username = "john_doe", password = "password123")
+#' check_credentials(credentials)
+#' #> [1] TRUE
+check_credentials <- function(credentials) {
+
+ assertthat::assert_that(
+ assertthat::has_name(credentials, "username"),
+ msg = "The credentials need to contain a 'username' field."
+ )
+
+ assertthat::assert_that(
+ assertthat::has_name(credentials, "password"),
+ msg = "The credentials need to contain a 'password' field."
+ )
+
+ assertthat::assert_that(
+ length(credentials) == 2,
+ msg = "The credentials object should have a length of 2."
+ )
+
+ assertthat::assert_that(
+ assertthat::is.string(credentials$username)
+ )
+
+ assertthat::assert_that(
+ assertthat::is.string(credentials$password)
+ )
+
+ return(TRUE)
+}
+
 #' Extract the OCPU temp key from a response object
 #'
 #' When posting a request to the opencpu api service without the json flag, a

inst/postman-helpers/find-postman-test-mismatch.R

@@ -0,0 +1,92 @@
+# check mismatch between js test and api response for list_acoustic_project_codes
+
+
+# load libraries ----------------------------------------------------------
+
+library(httr2)
+
+
+
+# set function to test ----------------------------------------------------
+
+fn_to_test <- "list_station_names"
+
+# get reponse -------------------------------------------------------------
+
+
+## build request ----------------------------------------------------------
+
+equest <-
+ request(
+ glue::glue(
+ "https://opencpu.lifewatch.be/library/etnservice/R/{fn_to_test}/json"
+ )
+ )
+
+response <-
+ request %>%
+ req_headers(
+ "Content-Type" = "application/json",
+ "Cookie" = "vliz_webc=vliz_webc2"
+ ) %>%
+ req_body_json(list(
+ credentials = list(
+ username = "[email protected]",
+ password = askpass::askpass("Please provide ETN db pwd")
+ )
+ )) %>%
+ req_method("POST") %>%
+ req_perform()
+
+request <- request %>%
+ req_headers(
+ "Content-Type" = "application/json",
+ "Cookie" = "vliz_webc=vliz_webc2"
+ ) %>%
+ req_body_json(list(
+ credentials = list(
+ username = "[email protected]",
+ password = askpass::askpass("Please provide ETN db pwd")
+ )
+ )) %>%
+ req_method("POST")
+
+# check against expectation -----------------------------------------------
+
+# Make sure we didn't get a HTTP error
+assertthat::assert_that(!httr2::resp_is_error(response))
+
+
+## extract current expectation --------------------------------------------
+expectation <- readr::read_lines(
+ glue::glue("tests/postman/test-{fn_to_test}.js")
+) %>%
+ grep("pm.expect(jsonData).to.include.members(",
+ .,
+ fixed = TRUE,
+ value = TRUE) %>%
+ stringr::str_extract_all('(?<=")[^,]*?(?=\\")') %>%
+ unlist()
+
+
+## extract response --------------------------------------------------------
+
+api_response_values <- httr2::resp_body_json(response) %>% unlist()
+
+# report mismatch ---------------------------------------------------------
+
+# missing expected project codes:
+api_response_values[
+ !expectation %in% api_response_values]
+
+# Values from expectation that are not in the values the api responded
+expectation[!expectation %in% api_response_values]
+
+# check if the response is always the same --------------------------------
+library(furrr)
+plan("multisession", workers = 10)
+furrr::future_map(rep(list(request), 100), ~resp_body_json(req_perform(.x))) %>%
+ purrr::map(digest::digest) %>%
+ unlist %>%
+ unique %>%
+ length(.) == 1

tests/testthat/test-get_acoustic_deployments.R

@@ -6,7 +6,13 @@ credentials <- list(
 test_that("get_acoustic_deployments() returns error for incorrect connection", {
  expect_error(
  get_acoustic_deployments(credentials = "not_a_credentials"),
- "Not a credentials object to database."
+ "The credentials need to contain a 'username' field",
+ fixed = TRUE
+ )
+ expect_error(
+ get_acoustic_deployments(credentials = list(username = "not a username",
+ password = "the wrong password")),
+ "Failed to connect to the database."
  )
 })