diff --git a/R/api-audit-log.R b/R/api-audit-log.R new file mode 100644 index 0000000..cba00fd --- /dev/null +++ b/R/api-audit-log.R @@ -0,0 +1,27 @@ +api_get_audit_log <- function(study_id, req, res) { + audit_log_disable_for_request(req) + + if (!check_study_exist(study_id = study_id)) { + res$status <- 404 + return( + list(error = "Study not found") + ) + } + + # Get audit trial + audit_trail <- dplyr::tbl(db_connection_pool, "audit_log") |> + dplyr::filter(study_id == !!study_id) |> + dplyr::arrange(created_at) |> + dplyr::collect() + + audit_trail$request_body <- purrr::map( + audit_trail$request_body, + jsonlite::fromJSON + ) + audit_trail$response_body <- purrr::map( + audit_trail$response_body, + jsonlite::fromJSON + ) + + return(audit_trail) +} diff --git a/R/api_create_study.R b/R/api_create_study.R index 0ee2513..f225e88 100644 --- a/R/api_create_study.R +++ b/R/api_create_study.R @@ -1,6 +1,8 @@ api__minimization_pocock <- function( # nolint: cyclocomp_linter. identifier, name, method, arms, covariates, p, req, res) { + audit_log_set_event_type("study_create", req) + collection <- checkmate::makeAssertCollection() checkmate::assert( @@ -135,15 +137,7 @@ api__minimization_pocock <- function( strata = strata ) - # Response ---------------------------------------------------------------- - - if (!is.null(r$error)) { - res$status <- 503 - return(list( - error = "There was a problem saving created study to the database", - details = r$error - )) - } + audit_log_set_study_id(r$study$id, req) response <- list( study = r$study diff --git a/R/api_get_randomization_list.R b/R/api_get_randomization_list.R index 2babe95..e2434b1 100644 --- a/R/api_get_randomization_list.R +++ b/R/api_get_randomization_list.R @@ -1,15 +1,10 @@ api_get_rand_list <- function(study_id, req, res) { + audit_log_set_event_type("get_rand_list", req) db_connection_pool <- get("db_connection_pool") study_id <- req$args$study_id - is_study <- - checkmate::test_true( - dplyr::tbl(db_connection_pool, "study") |> - dplyr::filter(id == study_id) |> - dplyr::collect() |> - nrow() > 0 - ) + is_study <- check_study_exist(study_id = study_id) if (!is_study) { res$status <- 404 @@ -17,6 +12,7 @@ api_get_rand_list <- function(study_id, req, res) { error = "Study not found" )) } + audit_log_set_study_id(study_id, req) patients <- dplyr::tbl(db_connection_pool, "patient") |> diff --git a/R/api_get_study.R b/R/api_get_study.R index e19b313..2317db2 100644 --- a/R/api_get_study.R +++ b/R/api_get_study.R @@ -1,4 +1,5 @@ -api_get_study <- function(res, req) { +api_get_study <- function(req, res) { + audit_log_disable_for_request(req) db_connection_pool <- get("db_connection_pool") study_list <- @@ -11,24 +12,18 @@ api_get_study <- function(res, req) { } api_get_study_records <- function(study_id, req, res) { + audit_log_set_event_type("get_study_record", req) db_connection_pool <- get("db_connection_pool") study_id <- req$args$study_id - is_study <- - checkmate::test_true( - dplyr::tbl(db_connection_pool, "study") |> - dplyr::filter(id == study_id) |> - dplyr::collect() |> - nrow() > 0 - ) - - if (!is_study) { + if (!check_study_exist(study_id)) { res$status <- 404 return(list( error = "Study not found" )) } + audit_log_set_study_id(study_id, req) study <- dplyr::tbl(db_connection_pool, "study") |> diff --git a/R/api_randomize.R b/R/api_randomize.R index b4884ef..28f39e2 100644 --- a/R/api_randomize.R +++ b/R/api_randomize.R @@ -27,27 +27,22 @@ parse_pocock_parameters <- } api__randomize_patient <- function(study_id, current_state, req, res) { + audit_log_set_event_type("randomize_patient", req) collection <- checkmate::makeAssertCollection() db_connection_pool <- get("db_connection_pool") study_id <- req$args$study_id - is_study <- - checkmate::test_true( - dplyr::tbl(db_connection_pool, "study") |> - dplyr::filter(id == study_id) |> - dplyr::collect() |> - nrow() > 0 - ) - - if (!is_study) { + if (!check_study_exist(study_id)) { res$status <- 404 return(list( error = "Study not found" )) } + audit_log_set_study_id(study_id, req) + # Retrieve study details, especially the ones about randomization method_randomization <- dplyr::tbl(db_connection_pool, "study") |> @@ -93,19 +88,11 @@ api__randomize_patient <- function(study_id, current_state, req, res) { unbiased:::save_patient(study_id, arm$arm_id, used = TRUE) |> select(-used) - if (!is.null(randomized_patient$error)) { - res$status <- 503 - return(list( - error = "There was a problem saving randomized patient to the database", - details = randomized_patient$error - )) - } else { - randomized_patient <- - randomized_patient |> - dplyr::mutate(arm_name = arm$name) |> - dplyr::rename(patient_id = id) |> - as.list() - - return(randomized_patient) - } + randomized_patient <- + randomized_patient |> + dplyr::mutate(arm_name = arm$name) |> + dplyr::rename(patient_id = id) |> + as.list() + + return(randomized_patient) } diff --git a/R/audit-trail.R b/R/audit-trail.R new file mode 100644 index 0000000..e6932a4 --- /dev/null +++ b/R/audit-trail.R @@ -0,0 +1,210 @@ +#' AuditLog Class +#' +#' This class is used internally to store audit logs for each request. +AuditLog <- R6::R6Class( # nolint: object_name_linter. + "AuditLog", + public = list( + initialize = function(request_method, endpoint_url) { + private$request_id <- uuid::UUIDgenerate() + private$request_method <- request_method + private$endpoint_url <- endpoint_url + }, + disable = function() { + private$disabled <- TRUE + }, + is_enabled = function() { + !private$disabled + }, + set_request_body = function(request_body) { + if (typeof(request_body) == "list") { + request_body <- jsonlite::toJSON(request_body, auto_unbox = TRUE) |> as.character() + } else if (!is.character(request_body)) { + request_body <- NA + } + private$request_body <- request_body + }, + set_response_body = function(response_body) { + checkmate::assert_false( + typeof(response_body) == "list" + ) + private$response_body <- response_body + }, + set_ip_address = function(ip_address) { + private$ip_address <- ip_address + }, + set_user_agent = function(user_agent) { + private$user_agent <- user_agent + }, + set_event_type = function(event_type) { + private$event_type <- event_type + }, + set_study_id = function(study_id) { + private$study_id <- study_id + }, + set_response_code = function(response_code) { + private$response_code <- response_code + }, + validate_log = function() { + checkmate::assert( + !private$disabled + ) + if (is.null(private$event_type)) { + if (private$response_code == 404) { + # "soft" validation failure for 404 errors + # it might be just invalid endpoint + # so we don't want to fail the request + return(FALSE) + } else { + stop("Event type not set for audit log. Please set the event type using `audit_log_event_type`") + } + } + return(TRUE) + }, + persist = function() { + checkmate::assert( + !private$disabled + ) + db_conn <- pool::localCheckout(db_connection_pool) + values <- list( + private$request_id, + private$event_type, + private$study_id, + private$endpoint_url, + private$request_method, + private$request_body, + private$response_code, + private$response_body, + private$ip_address, + private$user_agent + ) + + values <- purrr::map(values, \(x) ifelse(is.null(x), NA, x)) + + DBI::dbGetQuery( + db_conn, + "INSERT INTO audit_log ( + request_id, + event_type, + study_id, + endpoint_url, + request_method, + request_body, + response_code, + response_body, + ip_address, + user_agent + ) + VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10)", + values + ) + } + ), + private = list( + disabled = FALSE, + request_id = NULL, + event_type = NULL, + study_id = NULL, + endpoint_url = NULL, + request_method = NULL, + response_code = NULL, + request_body = NULL, + response_body = NULL, + ip_address = NULL, + user_agent = NULL + ) +) + + +#' Set up audit trail +#' +#' This function sets up an audit trail for a given process. It uses plumber's hooks to log +#' information before routing (preroute) and after serializing the response (postserialize). +#' +#' This function modifies the plumber router in place and returns the updated router. +#' +#' @param pr A plumber router for which the audit trail is to be set up. +#' @param endpoints A list of regex patterns for which the audit trail should be enabled. +#' @return Returns the updated plumber router with the audit trail hooks. +#' @examples +#' pr <- plumber::plumb("your-api-definition.R") |> +#' setup_audit_trail() +setup_audit_trail <- function(pr, endpoints = list()) { + checkmate::assert_list(endpoints, types = "character") + is_enabled_for_request <- function(req) { + any(sapply(endpoints, \(endpoint) grepl(endpoint, req$PATH_INFO))) + } + + hooks <- list( + preroute = function(req, res) { + with_err_handler({ + if (!is_enabled_for_request(req)) { + return() + } + audit_log <- AuditLog$new( + request_method = req$REQUEST_METHOD, + endpoint_url = req$PATH_INFO + ) + req$.internal.audit_log <- audit_log + }) + }, + postserialize = function(req, res) { + with_err_handler({ + audit_log <- req$.internal.audit_log + if (is.null(audit_log) || !audit_log$is_enabled()) { + return() + } + audit_log$set_response_code(res$status) + audit_log$set_request_body(req$body) + audit_log$set_response_body(res$body) + audit_log$set_ip_address(req$REMOTE_ADDR) + audit_log$set_user_agent(req$HTTP_USER_AGENT) + + log_valid <- audit_log$validate_log() + + if (log_valid) { + audit_log$persist() + } + }) + } + ) + pr |> + plumber::pr_hooks(hooks) +} + +#' Set Audit Log Event Type +#' +#' This function sets the event type for an audit log. It retrieves the audit log from the request's +#' internal data, and then calls the audit log's set_event_type method with the provided event type. +#' +#' @param event_type The event type to be set for the audit log. +#' @param req The request object, which should contain an audit log in its internal data. +#' @return Returns nothing as it modifies the audit log in-place. +audit_log_set_event_type <- function(event_type, req) { + audit_log <- req$.internal.audit_log + if (!is.null(audit_log)) { + audit_log$set_event_type(event_type) + } +} + +#' Set Audit Log Study ID +#' +#' This function sets the study ID for an audit log. It retrieves the audit log from the request's +#' internal data, and then calls the audit log's set_study_id method with the provided study ID. +#' +#' @param study_id The study ID to be set for the audit log. +#' @param req The request object, which should contain an audit log in its internal data. +#' @return Returns nothing as it modifies the audit log in-place. +audit_log_set_study_id <- function(study_id, req) { + checkmate::assert(!is.null(study_id) && is.numeric(study_id), "Study ID must be a number") + audit_log <- req$.internal.audit_log + if (!is.null(audit_log)) { + audit_log$set_study_id(study_id) + } +} + +audit_log_disable_for_request <- function(req) { + audit_log <- req$.internal.audit_log + if (!is.null(audit_log)) { + audit_log$disable() + } +} diff --git a/R/db.R b/R/db.R index 9c5da33..7f53acb 100644 --- a/R/db.R +++ b/R/db.R @@ -44,14 +44,23 @@ get_similar_studies <- function(name, identifier) { similar } +check_study_exist <- function(study_id) { + db_connection_pool <- get("db_connection_pool") + study_exists <- dplyr::tbl(db_connection_pool, "study") |> + dplyr::filter(id == !!study_id) |> + dplyr::collect() |> + nrow() > 0 + study_exists +} + create_study <- function( name, identifier, method, parameters, arms, strata) { db_connection_pool <- get("db_connection_pool", envir = .GlobalEnv) connection <- pool::localCheckout(db_connection_pool) - r <- tryCatch( + DBI::dbWithTransaction( + connection, { - DBI::dbBegin(connection) study_record <- list( name = name, identifier = identifier, @@ -134,35 +143,17 @@ create_study <- function( row.names = FALSE ) - DBI::dbCommit(connection) list(study = study) - }, - error = function(cond) { - logger::log_error("Error creating study: {cond}", cond = cond) - DBI::dbRollback(connection) - list(error = conditionMessage(cond)) } ) - - r } save_patient <- function(study_id, arm_id, used) { - r <- tryCatch( - { - randomized_patient <- DBI::dbGetQuery( - db_connection_pool, - "INSERT INTO patient (arm_id, study_id, used) - VALUES ($1, $2, $3) - RETURNING id, arm_id, used", - list(arm_id, study_id, used) - ) - }, - error = function(cond) { - logger::log_error("Error randomizing patient: {cond}", cond = cond) - list(error = conditionMessage(cond)) - } + DBI::dbGetQuery( + db_connection_pool, + "INSERT INTO patient (arm_id, study_id, used) + VALUES ($1, $2, $3) + RETURNING id, arm_id, used", + list(arm_id, study_id, used) ) - - return(r) } diff --git a/R/error-handling.R b/R/error-handling.R new file mode 100644 index 0000000..3b8cea6 --- /dev/null +++ b/R/error-handling.R @@ -0,0 +1,121 @@ +# hack to make sure we can mock the globalCallingHandlers +# this method needs to be present in the package environment for mocking to work +# linter disabled intentionally since this is internal method and cannot be renamed +globalCallingHandlers <- NULL # nolint + +#' setup_sentry function +#' +#' This function is used to configure Sentry, a service for real-time error tracking. +#' It uses the sentryR package to set up Sentry based on environment variables. +#' +#' @param None +#' +#' @return None. If the SENTRY_DSN environment variable is not set, the function will +#' return a message and stop execution. +#' +#' @examples +#' setup_sentry() +#' +#' @details +#' The function first checks if the SENTRY_DSN environment variable is set. If not, it +#' returns a message and stops execution. +#' If SENTRY_DSN is set, it uses the sentryR::configure_sentry function to set up Sentry with +#' the following parameters: +#' - dsn: The Data Source Name (DSN) is retrieved from the SENTRY_DSN environment variable. +#' - app_name: The application name is set to "unbiased". +#' - app_version: The application version is retrieved from the GITHUB_SHA environment variable. +#' If not set, it defaults to "unspecified". +#' - environment: The environment is retrieved from the SENTRY_ENVIRONMENT environment variable. +#' If not set, it defaults to "development". +#' - release: The release is retrieved from the SENTRY_RELEASE environment variable. +#' If not set, it defaults to "unspecified". +#' +#' @seealso \url{https://docs.sentry.io/} +setup_sentry <- function() { + sentry_dsn <- Sys.getenv("SENTRY_DSN") + if (sentry_dsn == "") { + message("SENTRY_DSN not set, skipping Sentry setup") + return() + } + + sentryR::configure_sentry( + dsn = sentry_dsn, + app_name = "unbiased", + app_version = Sys.getenv("GITHUB_SHA", "unspecified"), + environment = Sys.getenv("SENTRY_ENVIRONMENT", "development"), + release = Sys.getenv("SENTRY_RELEASE", "unspecified") + ) + + globalCallingHandlers( + error = global_calling_handler + ) +} + +global_calling_handler <- function(error) { + error$function_calls <- sys.calls() + sentryR::capture_exception(error) + signalCondition(error) +} + +wrap_endpoint <- function(z) { + f <- function(...) { + return(withCallingHandlers(z(...), error = rlang::entrace)) + } + return(f) +} + +setup_invalid_json_handler <- function(api) { + api |> + plumber::pr_filter("validate_input_json", \(req, res) { + if (length(req$bodyRaw) > 0) { + request_body <- req$bodyRaw |> rawToChar() + e <- tryCatch( + { + jsonlite::fromJSON(request_body) + NULL + }, + error = \(e) e + ) + if (!is.null(e)) { + print(glue::glue("Invalid JSON; requested endpoint: {req$PATH_INFO}")) + audit_log_set_event_type("malformed_request", req) + res$status <- 400 + return(list( + error = jsonlite::unbox("Invalid JSON"), + details = e$message |> strsplit("\n") |> unlist() + )) + } + } + + plumber::forward() + }) +} + +# nocov start +default_error_handler <- function(req, res, error) { + print(error, simplify = "branch") + + if (sentryR::is_sentry_configured()) { + if ("trace" %in% names(error)) { + error$function_calls <- error$trace$call + } else if (!("function_calls" %in% names(error))) { + error$function_calls <- sys.calls() + } + + sentryR::capture_exception(error) + } + + res$status <- 500 + + list( + error = "500 - Internal server error" + ) +} +# nocov end + +with_err_handler <- function(expr) { + withCallingHandlers( + expr = expr, + error = rlang::entrace, bottom = rlang::caller_env() + ) +} diff --git a/R/run-api.R b/R/run-api.R index 32bf0a8..94d1993 100644 --- a/R/run-api.R +++ b/R/run-api.R @@ -12,14 +12,6 @@ #' #' @export run_unbiased <- function() { - tryCatch( - { - rlang::global_entrace() - }, - error = function(e) { - message("Error setting up global_entrace, it is expected in testing environment: ", e$message) - } - ) setup_sentry() host <- Sys.getenv("UNBIASED_HOST", "0.0.0.0") port <- as.integer(Sys.getenv("UNBIASED_PORT", "3838")) @@ -43,66 +35,11 @@ run_unbiased <- function() { } else { # otherwise we assume that we are in the root directory of the repository # and we can use plumb method to run the API from the plumber.R file - plumber::plumb("./inst/plumber/unbiased_api/plumber.R") |> - plumber::pr_run(host = host, port = port) - } -} - -# hack to make sure we can mock the globalCallingHandlers -# this method needs to be present in the package environment for mocking to work -# linter disabled intentionally since this is internal method and cannot be renamed -globalCallingHandlers <- NULL # nolint -#' setup_sentry function -#' -#' This function is used to configure Sentry, a service for real-time error tracking. -#' It uses the sentryR package to set up Sentry based on environment variables. -#' -#' @param None -#' -#' @return None. If the SENTRY_DSN environment variable is not set, the function will -#' return a message and stop execution. -#' -#' @examples -#' setup_sentry() -#' -#' @details -#' The function first checks if the SENTRY_DSN environment variable is set. If not, it -#' returns a message and stops execution. -#' If SENTRY_DSN is set, it uses the sentryR::configure_sentry function to set up Sentry with -#' the following parameters: -#' - dsn: The Data Source Name (DSN) is retrieved from the SENTRY_DSN environment variable. -#' - app_name: The application name is set to "unbiased". -#' - app_version: The application version is retrieved from the GITHUB_SHA environment variable. -#' If not set, it defaults to "unspecified". -#' - environment: The environment is retrieved from the SENTRY_ENVIRONMENT environment variable. -#' If not set, it defaults to "development". -#' - release: The release is retrieved from the SENTRY_RELEASE environment variable. -#' If not set, it defaults to "unspecified". -#' -#' @seealso \url{https://docs.sentry.io/} -setup_sentry <- function() { - sentry_dsn <- Sys.getenv("SENTRY_DSN") - if (sentry_dsn == "") { - message("SENTRY_DSN not set, skipping Sentry setup") - return() + # Following line is excluded from code coverage because it is not possible to + # run the API from the plumber.R file in the test environment + # This branch is only used for local development + plumber::plumb("./inst/plumber/unbiased_api/plumber.R") |> # nocov start + plumber::pr_run(host = host, port = port) # nocov end } - - sentryR::configure_sentry( - dsn = sentry_dsn, - app_name = "unbiased", - app_version = Sys.getenv("GITHUB_SHA", "unspecified"), - environment = Sys.getenv("SENTRY_ENVIRONMENT", "development"), - release = Sys.getenv("SENTRY_RELEASE", "unspecified") - ) - - globalCallingHandlers( - error = global_calling_handler - ) -} - -global_calling_handler <- function(error) { - error$function_calls <- sys.calls() - sentryR::capture_exception(error) - signalCondition(error) } diff --git a/R/validation-utils.R b/R/validation-utils.R deleted file mode 100644 index 752c38c..0000000 --- a/R/validation-utils.R +++ /dev/null @@ -1,10 +0,0 @@ -#' Utility functions for validation - -append_error <- function(validation_errors, field, error) { - if (field %in% names(validation_errors)) { - validation_errors[[field]] <- c(validation_errors[[field]], error) - } else { - validation_errors[[field]] <- list(error) - } - return(validation_errors) -} diff --git a/inst/db/migrations/20240216102753_audit_trail.down.SQL b/inst/db/migrations/20240216102753_audit_trail.down.SQL new file mode 100644 index 0000000..4a15498 --- /dev/null +++ b/inst/db/migrations/20240216102753_audit_trail.down.SQL @@ -0,0 +1,2 @@ +DROP INDEX audit_log_study_id_idx; +DROP TABLE audit_log; diff --git a/inst/db/migrations/20240216102753_audit_trail.up.SQL b/inst/db/migrations/20240216102753_audit_trail.up.SQL new file mode 100644 index 0000000..c267f59 --- /dev/null +++ b/inst/db/migrations/20240216102753_audit_trail.up.SQL @@ -0,0 +1,17 @@ +CREATE TABLE audit_log ( + id UUID PRIMARY KEY DEFAULT gen_random_uuid() NOT NULL, + created_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT CURRENT_TIMESTAMP, + event_type TEXT NOT NULL, + request_id UUID NOT NULL, + study_id integer, + endpoint_url TEXT NOT NULL, + request_method TEXT NOT NULL, + request_body JSONB, + response_code integer NOT NULL, + response_body JSONB, + CONSTRAINT audit_log_study_id_fk + FOREIGN KEY (study_id) + REFERENCES study (id) +); + +CREATE INDEX audit_log_study_id_idx ON audit_log (study_id); diff --git a/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.down.sql b/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.down.sql new file mode 100644 index 0000000..d4baee8 --- /dev/null +++ b/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.down.sql @@ -0,0 +1,2 @@ +ALTER TABLE audit_log DROP COLUMN ip_address; +ALTER TABLE audit_log DROP COLUMN user_agent; \ No newline at end of file diff --git a/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.up.sql b/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.up.sql new file mode 100644 index 0000000..aa15654 --- /dev/null +++ b/inst/db/migrations/20240304105844_add_ip_address_and_user_agent_to_audit_log.up.sql @@ -0,0 +1,2 @@ +ALTER TABLE audit_log ADD COLUMN ip_address VARCHAR(255); +ALTER TABLE audit_log ADD COLUMN user_agent TEXT; \ No newline at end of file diff --git a/inst/plumber/unbiased_api/meta.R b/inst/plumber/unbiased_api/meta.R index 09622bf..ec157a3 100644 --- a/inst/plumber/unbiased_api/meta.R +++ b/inst/plumber/unbiased_api/meta.R @@ -6,7 +6,7 @@ #* @tag other #* @get /sha #* @serializer unboxedJSON -sentryR::with_captured_calls(function(req, res) { +unbiased:::wrap_endpoint(function(req, res) { sha <- Sys.getenv("GITHUB_SHA", unset = "NULL") if (sha == "NULL") { res$status <- 404 diff --git a/inst/plumber/unbiased_api/plumber.R b/inst/plumber/unbiased_api/plumber.R index 1fa78a4..7a9a5d7 100644 --- a/inst/plumber/unbiased_api/plumber.R +++ b/inst/plumber/unbiased_api/plumber.R @@ -20,14 +20,25 @@ #* #* @plumber function(api) { - meta <- plumber::pr("meta.R") |> - plumber::pr_set_error(sentryR::sentry_error_handler) - study <- plumber::pr("study.R") |> - plumber::pr_set_error(sentryR::sentry_error_handler) + meta <- plumber::pr("meta.R") + study <- plumber::pr("study.R") + + meta |> + plumber::pr_set_error(unbiased:::default_error_handler) + + study |> + plumber::pr_set_error(unbiased:::default_error_handler) + + api |> + plumber::pr_set_error(unbiased:::default_error_handler) |> + unbiased:::setup_invalid_json_handler() api |> plumber::pr_mount("/meta", meta) |> plumber::pr_mount("/study", study) |> + unbiased:::setup_audit_trail(endpoints = list( + "^/study.*" + )) |> plumber::pr_set_api_spec(function(spec) { spec$ paths$ @@ -99,12 +110,6 @@ function(req) { req$REQUEST_METHOD, req$PATH_INFO, "@", req$REMOTE_ADDR, "\n" ) - purrr::imap(req$args, function(arg, arg_name) { - cat("[ARG]", arg_name, "=", as.character(arg), "\n") - }) - if (req$postBody != "") { - cat("[BODY]", req$postBody, "\n") - } plumber::forward() } diff --git a/inst/plumber/unbiased_api/study.R b/inst/plumber/unbiased_api/study.R index dad162e..bc5c3a3 100644 --- a/inst/plumber/unbiased_api/study.R +++ b/inst/plumber/unbiased_api/study.R @@ -18,7 +18,7 @@ #* @post /minimisation_pocock #* @serializer unboxedJSON #* -sentryR::with_captured_calls(function( +unbiased:::wrap_endpoint(function( identifier, name, method, arms, covariates, p, req, res) { return( unbiased:::api__minimization_pocock( @@ -38,12 +38,31 @@ sentryR::with_captured_calls(function( #* @serializer unboxedJSON #* -sentryR::with_captured_calls(function(study_id, current_state, req, res) { +unbiased:::wrap_endpoint(function(study_id, current_state, req, res) { return( unbiased:::api__randomize_patient(study_id, current_state, req, res) ) }) + +#* Get study audit log +#* +#* Get the audit log for a study +#* +#* +#* @param study_id:int Study identifier +#* +#* @tag audit +#* @get //audit +#* @serializer unboxedJSON +#* +unbiased:::wrap_endpoint(function(study_id, req, res) { + return( + unbiased:::api_get_audit_log(study_id, req, res) + ) +}) + + #* Get all available studies #* #* @return tibble with study_id, identifier, name and method @@ -53,7 +72,7 @@ sentryR::with_captured_calls(function(study_id, current_state, req, res) { #* @serializer unboxedJSON #* -sentryR::with_captured_calls(function(req, res) { +unbiased:::wrap_endpoint(function(req, res) { return( unbiased:::api_get_study(req, res) ) @@ -69,7 +88,7 @@ sentryR::with_captured_calls(function(req, res) { #* @serializer unboxedJSON #* -sentryR::with_captured_calls(function(study_id, req, res) { +unbiased:::wrap_endpoint(function(study_id, req, res) { return( unbiased:::api_get_study_records(study_id, req, res) ) @@ -84,7 +103,7 @@ sentryR::with_captured_calls(function(study_id, req, res) { #* @serializer unboxedJSON #* -sentryR::with_captured_calls(function(study_id, req, res) { +unbiased:::wrap_endpoint(function(study_id, req, res) { return( unbiased:::api_get_rand_list(study_id, req, res) ) diff --git a/man/AuditLog.Rd b/man/AuditLog.Rd new file mode 100644 index 0000000..dd413d9 --- /dev/null +++ b/man/AuditLog.Rd @@ -0,0 +1,152 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/audit-trail.R +\name{AuditLog} +\alias{AuditLog} +\title{AuditLog Class} +\description{ +This class is used internally to store audit logs for each request. +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-AuditLog-new}{\code{AuditLog$new()}} +\item \href{#method-AuditLog-disable}{\code{AuditLog$disable()}} +\item \href{#method-AuditLog-is_enabled}{\code{AuditLog$is_enabled()}} +\item \href{#method-AuditLog-set_request_body}{\code{AuditLog$set_request_body()}} +\item \href{#method-AuditLog-set_response_body}{\code{AuditLog$set_response_body()}} +\item \href{#method-AuditLog-set_ip_address}{\code{AuditLog$set_ip_address()}} +\item \href{#method-AuditLog-set_user_agent}{\code{AuditLog$set_user_agent()}} +\item \href{#method-AuditLog-set_event_type}{\code{AuditLog$set_event_type()}} +\item \href{#method-AuditLog-set_study_id}{\code{AuditLog$set_study_id()}} +\item \href{#method-AuditLog-set_response_code}{\code{AuditLog$set_response_code()}} +\item \href{#method-AuditLog-validate_log}{\code{AuditLog$validate_log()}} +\item \href{#method-AuditLog-persist}{\code{AuditLog$persist()}} +\item \href{#method-AuditLog-clone}{\code{AuditLog$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-new}{}}} +\subsection{Method \code{new()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$new(request_method, endpoint_url)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-disable}{}}} +\subsection{Method \code{disable()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$disable()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-is_enabled}{}}} +\subsection{Method \code{is_enabled()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$is_enabled()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_request_body}{}}} +\subsection{Method \code{set_request_body()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_request_body(request_body)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_response_body}{}}} +\subsection{Method \code{set_response_body()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_response_body(response_body)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_ip_address}{}}} +\subsection{Method \code{set_ip_address()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_ip_address(ip_address)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_user_agent}{}}} +\subsection{Method \code{set_user_agent()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_user_agent(user_agent)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_event_type}{}}} +\subsection{Method \code{set_event_type()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_event_type(event_type)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_study_id}{}}} +\subsection{Method \code{set_study_id()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_study_id(study_id)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-set_response_code}{}}} +\subsection{Method \code{set_response_code()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$set_response_code(response_code)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-validate_log}{}}} +\subsection{Method \code{validate_log()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$validate_log()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-persist}{}}} +\subsection{Method \code{persist()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$persist()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-AuditLog-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{AuditLog$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/append_error.Rd b/man/append_error.Rd deleted file mode 100644 index b443d1c..0000000 --- a/man/append_error.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/validation-utils.R -\name{append_error} -\alias{append_error} -\title{Utility functions for validation} -\usage{ -append_error(validation_errors, field, error) -} -\description{ -Utility functions for validation -} diff --git a/man/audit_log_set_event_type.Rd b/man/audit_log_set_event_type.Rd new file mode 100644 index 0000000..40d7f85 --- /dev/null +++ b/man/audit_log_set_event_type.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/audit-trail.R +\name{audit_log_set_event_type} +\alias{audit_log_set_event_type} +\title{Set Audit Log Event Type} +\usage{ +audit_log_set_event_type(event_type, req) +} +\arguments{ +\item{event_type}{The event type to be set for the audit log.} + +\item{req}{The request object, which should contain an audit log in its internal data.} +} +\value{ +Returns nothing as it modifies the audit log in-place. +} +\description{ +This function sets the event type for an audit log. It retrieves the audit log from the request's +internal data, and then calls the audit log's set_event_type method with the provided event type. +} diff --git a/man/audit_log_set_study_id.Rd b/man/audit_log_set_study_id.Rd new file mode 100644 index 0000000..6fe9076 --- /dev/null +++ b/man/audit_log_set_study_id.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/audit-trail.R +\name{audit_log_set_study_id} +\alias{audit_log_set_study_id} +\title{Set Audit Log Study ID} +\usage{ +audit_log_set_study_id(study_id, req) +} +\arguments{ +\item{study_id}{The study ID to be set for the audit log.} + +\item{req}{The request object, which should contain an audit log in its internal data.} +} +\value{ +Returns nothing as it modifies the audit log in-place. +} +\description{ +This function sets the study ID for an audit log. It retrieves the audit log from the request's +internal data, and then calls the audit log's set_study_id method with the provided study ID. +} diff --git a/man/setup_audit_trail.Rd b/man/setup_audit_trail.Rd new file mode 100644 index 0000000..129039f --- /dev/null +++ b/man/setup_audit_trail.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/audit-trail.R +\name{setup_audit_trail} +\alias{setup_audit_trail} +\title{Set up audit trail} +\usage{ +setup_audit_trail(pr, endpoints = list()) +} +\arguments{ +\item{pr}{A plumber router for which the audit trail is to be set up.} + +\item{endpoints}{A list of regex patterns for which the audit trail should be enabled.} +} +\value{ +Returns the updated plumber router with the audit trail hooks. +} +\description{ +This function sets up an audit trail for a given process. It uses plumber's hooks to log +information before routing (preroute) and after serializing the response (postserialize). +} +\details{ +This function modifies the plumber router in place and returns the updated router. +} +\examples{ +pr <- plumber::plumb("your-api-definition.R") |> + setup_audit_trail() +} diff --git a/man/setup_sentry.Rd b/man/setup_sentry.Rd index 8de319a..911f563 100644 --- a/man/setup_sentry.Rd +++ b/man/setup_sentry.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/run-api.R +% Please edit documentation in R/error-handling.R \name{setup_sentry} \alias{setup_sentry} \title{setup_sentry function} diff --git a/migrate_db.sh b/migrate_db.sh old mode 100644 new mode 100755 diff --git a/renv.lock b/renv.lock index c4ecca1..87a7c19 100644 --- a/renv.lock +++ b/renv.lock @@ -1305,16 +1305,6 @@ ], "Hash": "001cecbeac1cff9301bdc3775ee46a86" }, - "logger": { - "Package": "logger", - "Version": "0.2.2", - "Source": "Repository", - "Repository": "RSPM", - "Requirements": [ - "utils" - ], - "Hash": "c269b06beb2bbadb0d058c0e6fa4ec3d" - }, "lubridate": { "Package": "lubridate", "Version": "1.9.3", diff --git a/tests/testthat/audit-log-test-helpers.R b/tests/testthat/audit-log-test-helpers.R new file mode 100644 index 0000000..f7b2e54 --- /dev/null +++ b/tests/testthat/audit-log-test-helpers.R @@ -0,0 +1,64 @@ +#' Assert Events Logged in Audit Trail +#' +#' This function checks if the expected events have been logged in the 'audit_log' table in the database. +#' This function should be used at the beginning of a test to ensure that the expected events are logged. +#' @param events A vector of expected event types that should be logged, in order +#' +#' @return This function does not return a value. It throws an error if the assertions fail. +#' +#' @examples +#' \dontrun{ +#' assert_events_logged(c("event1", "event2")) +#' } +assert_audit_trail_for_test <- function(events = list(), env = parent.frame()) { + # Get count of events logged from audit_log table in database + pool <- get("db_connection_pool", envir = .GlobalEnv) + conn <- pool::localCheckout(pool) + + event_count <- DBI::dbGetQuery( + conn, + "SELECT COUNT(*) FROM audit_log" + )$count + + withr::defer( + { + # gen new count + new_event_count <- DBI::dbGetQuery( + conn, + "SELECT COUNT(*) FROM audit_log" + )$count + + n <- length(events) + + # assert that the count has increased by number of events + testthat::expect_identical( + new_event_count, + event_count + n, + info = glue::glue("Expected {n} events to be logged") + ) + + if (n > 0) { + # get the last n events + last_n_events <- DBI::dbGetQuery( + conn, + glue::glue_sql( + "SELECT * FROM audit_log ORDER BY created_at DESC LIMIT {n};", + .con = conn + ) + ) + + event_types <- last_n_events |> + dplyr::pull("event_type") |> + rev() + + # assert that the last n events are the expected events + testthat::expect_equal( + event_types, + events, + info = "Expected events to be logged" + ) + } + }, + env + ) +} diff --git a/tests/testthat/fixtures/example_audit_logs.yml b/tests/testthat/fixtures/example_audit_logs.yml new file mode 100644 index 0000000..5b28b3c --- /dev/null +++ b/tests/testthat/fixtures/example_audit_logs.yml @@ -0,0 +1,87 @@ +study: + - identifier: 'TEST' + name: 'Test Study' + method: 'minimisation_pocock' + parameters: '{}' + - identifier: 'TEST2' + name: 'Test Study 2' + method: 'minimisation_pocock' + parameters: '{}' + - identifier: 'TEST3' + name: 'Test Study 3' + method: 'minimisation_pocock' + parameters: '{}' + +audit_log: + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70001" + created_at: "2022-02-16T10:27:53Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0001" + study_id: 1 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70002" + created_at: "2022-02-16T10:27:53Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0002" + study_id: 2 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70003" + created_at: "2022-02-16T10:27:53Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0003" + study_id: 2 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70004" + created_at: "2023-02-16T10:27:53Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0004" + study_id: 2 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70005" + created_at: "2022-02-16T10:27:54Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0004" + study_id: 2 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" + - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70006" + created_at: "2022-02-16T10:27:53Z" + event_type: "example_event" + request_id: "427ac2db-166d-4236-b040-94213f1b0006" + study_id: 3 + endpoint_url: "/api/example" + request_method: "GET" + request_body: '{"key1": "value1", "key2": "value2"}' + response_code: 200 + response_body: '{"key1": "value1", "key2": "value2"}' + ip_address: "8.8.8.8" + user_agent: "Mozilla" diff --git a/tests/testthat/setup-testing-environment.R b/tests/testthat/setup-testing-environment.R index bc06c31..dd4d790 100644 --- a/tests/testthat/setup-testing-environment.R +++ b/tests/testthat/setup-testing-environment.R @@ -281,8 +281,8 @@ request(api_url) |> req_url_path("meta", "sha") |> req_method("GET") |> req_retry( - max_tries = 25, - backoff = \(x) 0.3 + max_seconds = 30, + backoff = \(x) 1 ) |> req_perform() print("API started, running tests...") diff --git a/tests/testthat/test-E2E-get-study.R b/tests/testthat/test-E2E-get-study.R index d88e63c..dbb42de 100644 --- a/tests/testthat/test-E2E-get-study.R +++ b/tests/testthat/test-E2E-get-study.R @@ -1,11 +1,15 @@ test_that("correct request to reads studies with the structure of the returned result", { source("./test-helpers.R") + source("./audit-log-test-helpers.R") conn <- pool::localCheckout( get("db_connection_pool", envir = globalenv()) ) with_db_fixtures("fixtures/example_db.yml") + # this endpoint should not be logged + assert_audit_trail_for_test(c()) + response <- request(api_url) |> req_url_path("study", "") |> req_method("GET") |> diff --git a/tests/testthat/test-E2E-study-minimisation-pocock.R b/tests/testthat/test-E2E-study-minimisation-pocock.R index a821a7a..31394e3 100644 --- a/tests/testthat/test-E2E-study-minimisation-pocock.R +++ b/tests/testthat/test-E2E-study-minimisation-pocock.R @@ -1,4 +1,11 @@ test_that("correct request with the structure of the returned result", { + source("./test-helpers.R") + source("./audit-log-test-helpers.R") + with_db_fixtures("fixtures/example_db.yml") + assert_audit_trail_for_test(c( + "study_create", + "randomize_patient" + )) response <- request(api_url) |> req_url_path("study", "minimisation_pocock") |> req_method("POST") |> diff --git a/tests/testthat/test-api-audit-log.R b/tests/testthat/test-api-audit-log.R new file mode 100644 index 0000000..2ae767f --- /dev/null +++ b/tests/testthat/test-api-audit-log.R @@ -0,0 +1,88 @@ +source("./test-helpers.R") +source("./audit-log-test-helpers.R") + +testthat::test_that("audit logs for study are returned correctly from the database", { + with_db_fixtures("fixtures/example_audit_logs.yml") + studies <- c(1, 2, 3) + counts <- c(1, 4, 1) + for (i in 1:3) { + study_id <- studies[i] + count <- counts[i] |> + as.integer() + response <- request(api_url) |> + req_url_path("study", study_id, "audit") |> + req_method("GET") |> + req_perform() + + response_body <- + response |> + resp_body_json() + + testthat::expect_identical(response$status_code, 200L) + testthat::expect_identical(length(response_body), count) + + created_at <- response_body |> dplyr::bind_rows() |> dplyr::pull("created_at") + testthat::expect_equal( + created_at, + created_at |> sort() + ) + + if (count > 0) { + body <- response_body[[1]] + testthat::expect_setequal(names(body), c( + "id", + "created_at", + "event_type", + "request_id", + "study_id", + "endpoint_url", + "request_method", + "request_body", + "response_code", + "response_body", + "user_agent", + "ip_address" + )) + + testthat::expect_equal(body$study_id, study_id) + testthat::expect_equal(body$event_type, "example_event") + testthat::expect_equal(body$request_method, "GET") + testthat::expect_equal(body$endpoint_url, "/api/example") + testthat::expect_equal(body$response_code, 200) + testthat::expect_equal(body$request_body, list(key1 = "value1", key2 = "value2")) + testthat::expect_equal(body$response_body, list(key1 = "value1", key2 = "value2")) + } + } +}) + +testthat::test_that("should return 404 when study does not exist", { + with_db_fixtures("fixtures/example_audit_logs.yml") + response <- request(api_url) |> + req_url_path("study", 1111, "audit") |> + req_method("GET") |> + req_error(is_error = \(x) FALSE) |> + req_perform() + + response_body <- + response |> + resp_body_json() + + testthat::expect_equal(response$status_code, 404) + testthat::expect_equal(response_body$error, "Study not found") +}) + +testthat::test_that("should not log audit trail for non-existent endpoint", { + with_db_fixtures("fixtures/example_audit_logs.yml") + assert_audit_trail_for_test(events = c()) + response <- request(api_url) |> + req_url_path("study", 1, "non-existent-endpoint") |> + req_method("GET") |> + req_error(is_error = \(x) FALSE) |> + req_perform() + + response_body <- + response |> + resp_body_json() + + testthat::expect_equal(response$status_code, 404) +}) diff --git a/tests/testthat/test-run-api.R b/tests/testthat/test-error-handling.R similarity index 100% rename from tests/testthat/test-run-api.R rename to tests/testthat/test-error-handling.R diff --git a/tests/testthat/test-malformed-requests.R b/tests/testthat/test-malformed-requests.R new file mode 100644 index 0000000..22e279c --- /dev/null +++ b/tests/testthat/test-malformed-requests.R @@ -0,0 +1,17 @@ +source("./test-helpers.R") +source("./audit-log-test-helpers.R") + +testthat::test_that("should handle malformed request correctly", { + with_db_fixtures("fixtures/example_audit_logs.yml") + assert_audit_trail_for_test(events = c("malformed_request")) + malformed_json <- "test { test }" + response <- + request(api_url) |> + req_url_path("study") |> + req_method("POST") |> + req_error(is_error = \(x) FALSE) |> + req_body_raw(malformed_json) |> # <--- Malformed request + req_perform() + + testthat::expect_equal(response$status_code, 400) +})