tests

R/audit-trail.R

@@ -13,9 +13,6 @@ AuditLog <- R6::R6Class( # nolint: object_name_linter.
     disable = function() {
       private$disabled <- TRUE
     },
-    enable = function() {
-      private$disabled <- FALSE
-    },
     is_enabled = function() {
       !private$disabled
     },
@@ -41,17 +38,25 @@ AuditLog <- R6::R6Class( # nolint: object_name_linter.
       private$response_code <- response_code
     },
     validate_log = function() {
-      if (private$disabled) {
-        stop("Audit log is disabled")
-      }
+      checkmate::assert(
+        !private$disabled
+      )
       if (is.null(private$event_type)) {
-        stop("Event type not set for audit log. Please set the event type using `audit_log_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() {
-      if (private$disabled) {
-        return()
-      }
+      checkmate::assert(
+        !private$disabled
+      )
       db_conn <- pool::localCheckout(db_connection_pool)
       values <- list(
         private$request_id,
@@ -104,25 +109,19 @@ AuditLog <- R6::R6Class( # nolint: object_name_linter.
 #'
 #' This function modifies the plumber router in place and returns the updated router.
 #'
-#' The audit trail is only enabled if the AUDIT_LOG_ENABLED environment variable is set to "true".
-#'
 #' @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) {
-  audit_log_enabled <- Sys.getenv("AUDIT_LOG_ENABLED", "true") |> as.logical()
-  if (!audit_log_enabled) {
-    print("Audit log is disabled")
-    return(pr)
-  }
-  print("Audit log is enabled")
+setup_audit_trail <- function(pr, endpoints = list()) {
+  checkmate::assert(
+    is.list(endpoints),
+    all(sapply(endpoints, is.character)),
+    "endpoints must be a list of strings"
+  )
   is_enabled_for_request <- function(req) {
-    if (is.null(endpoints)) {
-      return(TRUE)
-    }
     any(sapply(endpoints, \(endpoint) grepl(endpoint, req$PATH_INFO)))
   }
 
@@ -146,11 +145,13 @@ setup_audit_trail <- function(pr, endpoints) {
         if (is.null(audit_log) || !audit_log$is_enabled()) {
           return()
         }
-        audit_log$validate_log()
         audit_log$set_response_code(res$status)
         audit_log$set_request_body(req$body)
         audit_log$set_response_body(res$body)
-        audit_log$persist()
+
+        if (audit_log$validate_log()) {
+          audit_log$persist()
+        }
       })
     }
   )

R/error-handling.R

@@ -1,4 +1,3 @@
-
 # 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
@@ -86,4 +85,4 @@ with_err_handler <- function(expr) {
     expr = expr,
     error = rlang::entrace, bottom = rlang::caller_env()
   )
-}
+}

R/run-api.R

@@ -43,4 +43,3 @@ run_unbiased <- function() {
       plumber::pr_run(host = host, port = port) # nocov end
   }
 }
-

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",

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_equal(
+        new_event_count,
+        event_count + n,
+        info = "Expected 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
+  )
+}

tests/testthat/fixtures/example_audit_logs.yml

@@ -0,0 +1,75 @@
+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"}'
+  - 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"}'
+  - 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"}'
+  - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70004"
+    created_at: "2022-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"}'
+  - id: "c12d29e7-1b44-4cb6-a9c1-1f427fe70005"
+    created_at: "2022-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"}'
+  - 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"}'

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...")

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_study.yml")
 
+  # this endpoint should not be logged
+  assert_audit_trail_for_test(c())
+
   response <- request(api_url) |>
     req_url_path("study", "") |>
     req_method("GET") |>

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_study.yml")
+  assert_audit_trail_for_test(c(
+    "study_create",
+    "randomize_patient"
+  ))
   response <- request(api_url) |>
     req_url_path("study", "minimisation_pocock") |>
     req_method("POST") |>

tests/testthat/test-api-audit-log.R

@@ -0,0 +1,76 @@
+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]
+    response <- request(api_url) |>
+      req_url_path("study", study_id, "audit") |>
+      req_method("GET") |>
+      req_perform()
+
+    response_body <-
+      response |>
+      resp_body_json()
+
+    testthat::expect_equal(response$status_code, 200)
+    testthat::expect_equal(length(response_body), count)
+
+    if (count > 0) {
+      body <- response_body[[1]]
+      testthat::expect_equal(names(body), c(
+        "id",
+        "created_at",
+        "event_type",
+        "request_id",
+        "study_id",
+        "endpoint_url",
+        "request_method",
+        "request_body",
+        "response_code",
+        "response_body"
+      ))
+      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", {
+  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", {
+  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)
+})