diff --git a/DESCRIPTION b/DESCRIPTION index dd42b96..db4349b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: dsROCrate Title: 'DataSHIELD' RO-Crate Governance Functions -Version: 0.1.0 +Version: 0.2.0 Authors@R: c( person(given = "Roberto", family = "Villegas-Diaz", @@ -33,7 +33,7 @@ Suggests: fs, knitr, MolgenisArmadillo, - testthat (>= 3.0.0), + testthat (>= 3.1.4), withr Config/testthat/edition: 3 Encoding: UTF-8 @@ -50,6 +50,7 @@ Imports: rmarkdown, rocrateR (>= 0.1.0), tibble, + uuid, vtree, xptr, yaml diff --git a/NAMESPACE b/NAMESPACE index adeeb38..3608585 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,13 +1,33 @@ # Generated by roxygen2: do not edit by hand +S3method(as.data.frame,safe_call) +S3method(as.data.frame,symbol_registry) S3method(audit,ArmadilloCredentials) S3method(audit,character) S3method(audit,cr8tor) +S3method(audit,default) S3method(audit,list) S3method(audit,opal) S3method(audit,rocrate) S3method(audit_engine,cr8tor) +S3method(audit_engine,default) S3method(audit_engine,opal) +S3method(backend_logs,opal) +S3method(backend_options,opal) +S3method(backend_packages,opal) +S3method(backend_profile_exists,opal) +S3method(backend_project,opal) +S3method(backend_project_exists,opal) +S3method(backend_project_perms,opal) +S3method(backend_projects,opal) +S3method(backend_resource_perms,opal) +S3method(backend_resources,opal) +S3method(backend_sys_perms,opal) +S3method(backend_table_perms,opal) +S3method(backend_tables,opal) +S3method(backend_user_exists,opal) +S3method(backend_users,opal) +S3method(check_permissions,ArmadilloCredentials) S3method(check_permissions,default) S3method(check_permissions,opal) S3method(extract_safe_data,opal) @@ -20,6 +40,7 @@ S3method(extract_safe_project,opal) S3method(extract_safe_project,rocrate) S3method(extract_safe_setting,opal) S3method(extract_safe_setting,rocrate) +S3method(filter_safe_people,opal) S3method(flatten_safe_data,default) S3method(flatten_safe_data,rocrate) S3method(flatten_safe_output,default) @@ -30,25 +51,37 @@ S3method(flatten_safe_project,default) S3method(flatten_safe_project,rocrate) S3method(flatten_safe_setting,default) S3method(flatten_safe_setting,rocrate) +S3method(has_symbol,symbol_registry) +S3method(init,ArmadilloCredentials) S3method(init,opal) S3method(init,rocrate) +S3method(is_admin_con,opal) +S3method(is_audit_con,opal) S3method(parse_user_profiles,ArmadilloCredentials) S3method(parse_user_profiles,opal) S3method(print,cr8tor_bundle) +S3method(print,safe_call) +S3method(print,safe_symbol) S3method(project_exists,ArmadilloCredentials) S3method(project_exists,opal) +S3method(report,ArmadilloCredentials) S3method(report,character) S3method(report,default) S3method(report,list) S3method(report,rocrate) +S3method(safe_call,call) +S3method(safe_call,character) +S3method(safe_data,ArmadilloCredentials) S3method(safe_data,character) S3method(safe_data,default) S3method(safe_data,opal) S3method(safe_data,rocrate) +S3method(safe_output,ArmadilloCredentials) S3method(safe_output,character) S3method(safe_output,default) S3method(safe_output,opal) S3method(safe_output,rocrate) +S3method(safe_people,ArmadilloCredentials) S3method(safe_people,character) S3method(safe_people,default) S3method(safe_people,opal) @@ -58,6 +91,7 @@ S3method(safe_project,character) S3method(safe_project,default) S3method(safe_project,opal) S3method(safe_project,rocrate) +S3method(safe_setting,ArmadilloCredentials) S3method(safe_setting,character) S3method(safe_setting,cr8tor) S3method(safe_setting,default) diff --git a/NEWS.md b/NEWS.md index a4e189d..26c254a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,35 @@ +# dsROCrate 0.2.0 + +## Breaking Changes + +* The audit log tibble returned via `safe_output()` no longer includes a `table` column. It has been replaced by three more granular columns: `kind` (whether the tracked object is a `table`, `resource` or `expression`), `asset` (the resolved table/resource name) and `expr` (the associated R expression, when applicable). Code that reads the `table` column directly will need to be updated. + +## New Features + +* Added a symbol registry and call-tracking system (`safe_symbol()`, `safe_call()`, `safe_reference()`, `symbol_registry()`) that replaces regex-based parsing of Opal logs, modelling assignments and aggregate function calls as objects and resolving arguments back to the symbols/tables they reference. +* Added a generic backend abstraction layer (`backend_logs()`, `backend_options()`, `backend_users()`, `backend_projects()`, `backend_sys_perms()`, and others) so internal code no longer calls `opalr::` directly, paving the way for additional backends. +* Added early Armadillo backend scaffolding: `check_permissions()`, `init()`, `report()`, `safe_data()`, `safe_output()`, `safe_people()` and `safe_setting()` now all have `ArmadilloCredentials` methods, returning clear "not yet implemented" errors ahead of full support. +* Added `default` S3 methods for `audit()`, `audit_engine()` and `check_permissions()`, giving clearer errors when an unsupported connection object is supplied. +* Added a `verbose` argument to `check_permissions()` (opal method) to optionally print a success message when permissions are sufficient. +* Added `print.safe_call()` and `print.safe_symbol()` methods, plus `as.data.frame()` methods for `safe_call` and `symbol_registry` objects, for readable inspection of the new internal tracking objects. + +## Improvements + +* `safe_people()` now determines admin/auditor status from actual system permissions and group membership, rather than a hardcoded name check against `"admin"`/`"administrator"`, improving compatibility with deployments that use differently named privileged accounts. +* Permission lookup failures during `safe_people()` now fall back gracefully to an empty result instead of aborting the whole audit. +* Consolidated backend-version and connection-validation logic into the new generic backend framework, reducing duplication between Opal-specific code paths. + +## Documentation + +* Removed a vignette section demonstrating direct calls to internal helper functions, which have since been renamed as part of the backend abstraction work. +* Updated documentation to reflect that `init()`, `safe_data()`, `report()` and related functions now accept either `opal` or `ArmadilloCredentials` connections. + +## Internal Changes + +* Added test coverage for `audit()`, `audit_engine()` and `check_permissions()`, along with a mock-connection test helper, reducing reliance on a live demo Opal server. +* Added `uuid` to `Imports`, used to generate unique IDs for tracked symbols. +* Bumped the `testthat` version requirement in `Suggests` from `>= 3.0.0` to `>= 3.1.4`. + # dsROCrate 0.1.0 ## New Features diff --git a/R/audit.R b/R/audit.R index fc88fd7..6aa1852 100644 --- a/R/audit.R +++ b/R/audit.R @@ -47,11 +47,22 @@ audit <- function(x, ...) { UseMethod("audit") } +#' @export +audit.default <- function(x, ...) { + stop( + sprintf( + "No `audit()` method exists for objects of class: %s.", + paste(class(x), collapse = ", ") + ), + call. = FALSE + ) +} + #' @rdname audit #' @export audit.ArmadilloCredentials <- function(x, ..., intent = NULL) { stop( - "The audit for Armadillo backend is not currently implemented!", + "The `audit()` for the Armadillo backend is not currently implemented!", call. = FALSE ) } @@ -65,21 +76,27 @@ audit.character <- function(x, ..., intent = NULL) { } # attempt loading a `cr8tor` bundle - x_obj <- tryCatch( - load_cr8tor_bundle(x, ...), - error = function(e) NULL - ) + cr8tor_res <- .try_load(load_cr8tor_bundle(x, ...)) + x_obj <- cr8tor_res$value + # alternatively, attempt loading an RO-Crate + rocrate_res <- list(value = NULL, error = NULL) if (is.null(x_obj)) { - x_obj <- tryCatch( - rocrateR::load_rocrate(x, ...), - error = function(e) NULL - ) + rocrate_res <- .try_load(rocrateR::load_rocrate(x, ...)) + x_obj <- rocrate_res$value } if (is.null(x_obj)) { stop( - "The given path does not point to a valid `cr8tor` archive nor an `rocrate", + paste0( + "The given path does not point to a valid `cr8tor` archive nor an ", + "`rocrate`.\n\n", + " cr8tor bundle error: ", + if (is.null(cr8tor_res$error)) "(not attempted)" else cr8tor_res$error, + "\n", + " rocrate error: ", + if (is.null(rocrate_res$error)) "(not attempted)" else rocrate_res$error + ), call. = FALSE ) } diff --git a/R/audit_engine.R b/R/audit_engine.R index f554ffd..000cf52 100644 --- a/R/audit_engine.R +++ b/R/audit_engine.R @@ -3,9 +3,9 @@ #' Internal function to create audits for various back-ends. #' #' @param x This can be a connection to a 'DataSHIELD' server (e.g., object with -#' the `opal` class, see [opalr::opal.login()]). Alternatively, a governance -#' archive file, representing the intent of a project and associated -#' governance details. +#' the `opal` or `ArmadilloCredentials` classes). Alternatively, a +#' governance archive file, representing the intent of a project and +#' associated governance details. #' @param ... Other optional arguments, see full documentation for details. #' @param project String with project name(s) from which to extra Safe Project #' details. @@ -26,6 +26,17 @@ audit_engine <- function(x, ...) { UseMethod("audit_engine") } +#' @export +audit_engine.default <- function(x, ...) { + stop( + sprintf( + "No `audit_engine()` method exists for objects of class: %s.", + paste(class(x), collapse = ", ") + ), + call. = FALSE + ) +} + #' @export audit_engine.cr8tor <- function(x, ...) { # extract individual components from cr8tor bundle @@ -57,7 +68,7 @@ audit_engine.opal <- function( path = NULL ) { # local bindings - name <- permission <- principal <- NULL + name <- NULL # create RO-Create with the 5 safes profile crate <- rocrateR::rocrate_5s() @@ -65,13 +76,13 @@ audit_engine.opal <- function( # validate backend validate_backend(x, ...) - # if `project` is missing, then ~extract all project names~ error + # if `project` is missing, then error if (is.null(project)) { stop("A `project` name is required!", call. = FALSE) } # extract list with all projects to verify `project` contains a valid value - ds <- opalr::opal.projects(x) + ds <- backend_projects(x) server_prjs <- ds[, "name"] idx <- project %in% server_prjs if (!all(idx)) { @@ -86,41 +97,30 @@ audit_engine.opal <- function( # Safe People ---- # get users' details - safe_people_tbl <- opalr::oadmin.user_profiles(x, df = FALSE) |> - dplyr::bind_rows() |> - dplyr::rename(name = principal) |> - # exclude system administrators from the report - dplyr::filter(!(tolower(name) %in% c("admin", "administrator"))) - - # if any users were found, then verify if they are admin/auditors and exclude - if (nrow(safe_people_tbl)) { - # extract system permissions - sys_perms_tbl <- opalr::oadmin.system_perm(x) - safe_people_tbl <- tryCatch( - { - safe_people_tbl |> - dplyr::left_join(sys_perms_tbl, by = c("name" = "subject")) |> - dplyr::filter(!(permission %in% c("administrate", "audit"))) - }, - error = function(e) { - tibble::tibble() - } - ) - } - + safe_people_tbl <- filter_safe_people(x) if (!is.null(user)) { safe_people_tbl <- safe_people_tbl |> dplyr::filter(tolower(name) %in% user) + } - if (nrow(safe_people_tbl) == 0) { - stop( + # an audit report is not meaningful without Safe People details, whether + # that's because a `user` filter matched nobody, or because the + # permission lookup itself could not be completed + if (nrow(safe_people_tbl) == 0) { + stop( + if (is.null(user)) { + paste( + "No Safe People details could be found for this project - the", + "audit cannot proceed." + ) + } else { sprintf( "No Safe People details were found for the user: %s!", paste0("'", user, "'", collapse = ", ") - ), - call. = FALSE - ) - } + ) + }, + call. = FALSE + ) } crate <- safe_people_tbl$name |> diff --git a/R/backend-generic.R b/R/backend-generic.R new file mode 100644 index 0000000..d9873bf --- /dev/null +++ b/R/backend-generic.R @@ -0,0 +1,128 @@ +backend_logs <- function(x, ...) { + UseMethod("backend_logs") +} + +backend_options <- function(x, ...) { + UseMethod("backend_options") +} + +backend_packages <- function(x, ...) { + UseMethod("backend_packages") +} + +backend_profile_exists <- function(x, ...) { + UseMethod("backend_profile_exists") +} + +backend_project <- function(x, ...) { + UseMethod("backend_project") +} + +backend_project_exists <- function(x, ...) { + UseMethod("backend_project_exists") +} + +backend_project_perms <- function(x, ...) { + UseMethod("backend_project_perms") +} + +backend_projects <- function(x, ...) { + UseMethod("backend_projects") +} + +backend_resource_perms <- function(x, ...) { + UseMethod("backend_resource_perms") +} + +backend_resources <- function(x, ...) { + UseMethod("backend_resources") +} + +backend_sys_perms <- function(x, ...) { + UseMethod("backend_sys_perms") +} + +backend_table_perms <- function(x, ...) { + UseMethod("backend_table_perms") +} + +backend_tables <- function(x, ...) { + UseMethod("backend_tables") +} + +backend_user_exists <- function(x, ...) { + UseMethod("backend_user_exists") +} + +backend_users <- function(x, ...) { + UseMethod("backend_users") +} + +#' Verify if connection was created by an administrator user +#' +#' @inheritParams validate_con +#' @param ... Unused, extra arguments. +#' +#' @returns Boolean flag to indicate whether the given connection was created +#' by an administrator user. +#' @keywords internal +#' +#' @noRd +is_admin_con <- function(x, ...) { + UseMethod("is_admin_con") +} + +#' Verify if connection was created by an auditor user +#' +#' @inheritParams validate_con +#' @param ... Unused, extra arguments. +#' +#' @returns Boolean flag to indicate whether the given connection was created +#' by an auditor user. +#' @keywords internal +#' +#' @noRd +is_audit_con <- function(x, ...) { + UseMethod("is_audit_con") +} + +#' Validate backend version +#' +#' @param x DataSHIELD backend connection object. +#' @param ... Unused. +#' @param minimum String with minimum version. +#' +#' @returns Logical value indicating if backend version is valid. +#' @keywords internal +#' @noRd +validate_backend_version <- function(x, ...) { + UseMethod("validate_backend_version") +} + +#' @export +validate_backend_version.default <- function(x, ...) { + invisible(TRUE) +} + +#' Validate backend connection +#' +#' @param x DataSHIELD backend connection object. +#' @param ... Unused. +#' +#' @returns Nothing, call for its side effect. +#' @keywords internal +#' @noRd +validate_con <- function(x, ...) { + UseMethod("validate_con") +} + +#' @export +validate_con.default <- function(x, ...) { + stop( + sprintf( + "Unsupported connection type: %s", + paste(class(x), collapse = ", ") + ), + call. = FALSE + ) +} diff --git a/R/backend-opal.R b/R/backend-opal.R new file mode 100644 index 0000000..1d98694 --- /dev/null +++ b/R/backend-opal.R @@ -0,0 +1,139 @@ +#' @export +backend_logs.opal <- function(x, ...) { + opalr::dsadmin.log(x, ...) +} + +#' @export +backend_options.opal <- function(x, ...) { + opalr::dsadmin.get_options(x, ...) +} + +#' @export +backend_packages.opal <- function(x, ...) { + opalr::dsadmin.package_descriptions(x, ...) +} + +#' @export +backend_profile_exists.opal <- function(x, ...) { + opalr::dsadmin.profile_exists(x, ...) +} + +#' @export +backend_project.opal <- function(x, ...) { + opalr::opal.project(x, ...) +} + +#' @export +backend_project_exists.opal <- function(x, ...) { + opalr::opal.project_exists(x, ...) +} + +#' @export +backend_project_perms.opal <- function(x, ...) { + opalr::opal.project_perm(x, ...) +} + +#' @export +backend_projects.opal <- function(x, ...) { + opalr::opal.projects(x, ...) +} + +#' @export +backend_resource_perms.opal <- function(x, ...) { + opalr::opal.resource_perm(x, ...) +} + +#' @export +backend_resources.opal <- function(x, ...) { + opalr::opal.resources(x, ...) +} + +#' @export +backend_sys_perms.opal <- function(x, ...) { + opalr::oadmin.system_perm(x, ...) +} + +#' @export +backend_table_perms.opal <- function(x, ...) { + opalr::opal.table_perm(x, ...) +} + +#' @export +backend_tables.opal <- function(x, ...) { + opalr::opal.tables(x, ...) +} + +#' @export +backend_user_exists.opal <- function(x, ...) { + opalr::oadmin.user_exists(x, ...) +} + +#' @export +backend_users.opal <- function(x, ...) { + opalr::oadmin.user_profiles(x, ...) +} + +#' @export +is_admin_con.opal <- function(x, ...) { + # condition 1: admin users have access to `backend_user_exists` + cond1 <- .try_load(backend_user_exists(x, x$username)) + # condition 2: admin users have access to `backend_profile_exists` + cond2 <- .try_load(backend_profile_exists(x, "default")) + + # check all the conditions are met + result <- all(!is.null(cond1$value), !is.null(cond2$value)) + attr(result, "error") <- list( + user_exists = cond1$error, + profile_exists = cond2$error + ) + result +} + +#' @export +is_audit_con.opal <- function(x, ...) { + # condition 1: admin users have access to `backend_user_exists` + cond1 <- .try_load(backend_user_exists(x, x$username)) + # condition 2: admin users have access to `backend_profile_exists` + cond2 <- .try_load(backend_profile_exists(x, "default")) + + # check all the conditions are met + # cond1 is met when the call *errored* (no admin access, as expected of + # a pure auditor); cond2 is met when the call *succeeded* - the returned + # values don't matter either way + result <- all(!is.null(cond1$error), !is.null(cond2$value)) + attr(result, "error") <- list( + user_exists = NULL, # an error here is expected/correct for an auditor, + profile_exists = cond2$error + ) + result +} + +#' @export +validate_backend_version.opal <- function(x, ..., minimum = "5.7.2") { + if (utils::compareVersion(x$version, minimum) < 0) { + stop( + sprintf( + "Opal >= %s is required, but server version is %s.", + minimum, + x$version + ), + call. = FALSE + ) + } + invisible(TRUE) +} + +#' @export +validate_con.opal <- function(x, ...) { + tryCatch( + { + status <- xptr::is_null_xptr(x$handle$handle) + if (status) { + stop("The given connection is not valid!", call. = FALSE) + } + }, + error = function(e) { + stop("The given connection is not valid!", call. = FALSE) + } + ) +} diff --git a/R/check_permissions.R b/R/check_permissions.R index a3eb91b..603a70a 100644 --- a/R/check_permissions.R +++ b/R/check_permissions.R @@ -7,6 +7,8 @@ #' #' @param x A backend connection object. #' @param ... Additional arguments passed to methods. +#' @param verbose Boolean value used to indicate if a success message should be +#' displayed (default: FALSE) #' #' @returns #' Returns `TRUE` invisibly if the connection has sufficient permissions. @@ -19,6 +21,7 @@ check_permissions <- function(x, ...) { UseMethod("check_permissions") } +# @rdname check_permissions #' @export check_permissions.default <- function(x, ...) { stop( @@ -33,22 +36,38 @@ check_permissions.default <- function(x, ...) { ) } +#' @rdname check_permissions #' @export -check_permissions.opal <- function(x, ...) { +check_permissions.ArmadilloCredentials <- function(x, ...) { + stop( + paste0( + "`check_permissions()` for the Armadillo backend is ", + "not currently implemented!" + ), + call. = FALSE + ) +} + +#' @rdname check_permissions +#' @export +check_permissions.opal <- function(x, ..., verbose = FALSE) { is_admin <- FALSE is_audit <- FALSE is_admin <- tryCatch( - is_opal_admin_con(x), + is_admin_con(x), error = function(e) FALSE ) is_audit <- tryCatch( - is_opal_audit_con(x), + is_audit_con(x), error = function(e) FALSE ) if (isTRUE(is_admin) || isTRUE(is_audit)) { + if (verbose) { + message("You are ready to audit this system!") + } return(invisible(TRUE)) } diff --git a/R/dsROCrate.R b/R/dsROCrate.R index c8bcc33..1e0a278 100644 --- a/R/dsROCrate.R +++ b/R/dsROCrate.R @@ -3,7 +3,7 @@ #' Creates a new RO-Crate configured for Five Safes auditing. #' #' @param x This can be a connection to a 'DataSHIELD' server (e.g., object with -#' the `opal` class, see [opalr::opal.login()]), an RO-Crate +#' the `opal` or `ArmadilloCredentials` classes), an RO-Crate #' ([rocrate][rocrateR::rocrate()] class) or a string with the path to an #' RO-Crate. #' @param ... Other optional arguments. See the full documentation, @@ -41,6 +41,15 @@ init <- function(x, ...) { UseMethod("init") } +#' @rdname init +#' @export +init.ArmadilloCredentials <- function(x, ...) { + stop( + "`init()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname init #' @export init.opal <- function( @@ -94,5 +103,5 @@ init.rocrate <- function( ) } -# # helper functions ---- -# `%||%` <- function(a, b) if (!is.null(a) && !is.na(a) && a != "") a else b +# helper functions ---- +`%||%` <- function(a, b) if (!is.null(a) && !is.na(a) && a != "") a else b diff --git a/R/print.R b/R/print.R index 931afeb..bf3bf85 100644 --- a/R/print.R +++ b/R/print.R @@ -47,3 +47,56 @@ print.cr8tor_bundle <- function(x, ...) { invisible(x) } + +#' @export +print.safe_call <- function(x, ...) { + msg <- "" + msg <- c(msg, paste("Function:", paste0(x$package, "::", x$fx))) + + if (length(x$args)) { + msg <- c(msg, "Arguments:") + msg <- c( + msg, + purrr::map2(x$args, names(x$args), function(arg_val, arg_name) { + if ("safe_symbol" %in% class(arg_val)) { + paste0(" ", arg_name, " = ", arg_val$symbol, collapse = "\n") + } else { + paste0(" ", arg_name, " = ", unlist(arg_val), collapse = "\n") + } + }) + ) + # msg <- c( + # msg, + # paste0(" ", names(x$args), " = ", unlist(x$args), collapse = "\n") + # ) + } + + message(paste0(msg, collapse = "\n")) + + invisible(x) +} + +#' @export +print.safe_symbol <- function(x, ...) { + msg <- "" + + msg <- c(msg, paste("ID :", x$id)) + msg <- c(msg, paste("Symbol :", x$symbol)) + msg <- c(msg, paste("Kind :", x$kind)) + + if (!is.null(x$asset)) { + msg <- c(msg, paste("Asset :", x$asset)) + } + + if (!is.null(x$column)) { + msg <- c(msg, paste("Column :", x$column)) + } + + if (!is.null(x$parent)) { + msg <- c(msg, paste("Parent :", x$parent)) + } + + message(paste0(msg, collapse = "\n")) + + invisible(x) +} diff --git a/R/report.R b/R/report.R index 6f3dfda..c242b20 100644 --- a/R/report.R +++ b/R/report.R @@ -11,6 +11,15 @@ report <- function(x, ...) { UseMethod("report") } +#' @rdname report +#' @export +report.ArmadilloCredentials <- function(x, ...) { + stop( + "The `report()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname report #' @export report.character <- function( @@ -45,7 +54,7 @@ report.character <- function( ) } -#' @rdname report +# @rdname report #' @export report.default <- function(x, ...) { stop( @@ -495,11 +504,11 @@ report.rocrate <- function( safe_output_tbl_v2 <- tibble::tibble() if (!is.null(safe_output_tbl) && nrow(safe_output_tbl) > 0) { - # split `table` into `project` and `table` + # split `asset` into `project` and `asset` safe_output_tbl_v2 <- safe_output_tbl |> dplyr::mutate( - project = gsub("(?=\\.).*$", "", table, perl = TRUE), - asset = gsub("^.*(?<=\\.)", "", table, perl = TRUE) + project = gsub("(?=\\.).*$", "", asset, perl = TRUE), + asset = gsub("^.*(?<=\\.)", "", asset, perl = TRUE) ) |> dplyr::distinct(project, asset, user, fx, timestamp) @@ -511,8 +520,8 @@ report.rocrate <- function( ) |> # replace 'NA' in fx & timestamp with empty string dplyr::mutate( - timestamp = dplyr::case_when(is.na(timestamp) ~ "", T ~ timestamp), - fx = dplyr::case_when(is.na(fx) ~ "", T ~ fx) + timestamp = dplyr::case_when(is.na(timestamp) ~ "", TRUE ~ timestamp), + fx = dplyr::case_when(is.na(fx) ~ "", TRUE ~ fx) ) } @@ -535,7 +544,7 @@ report.rocrate <- function( report_contents <- c( .markdown_report_header(title, overview_tbl, overview_lst$diag_path), tidy_overview_tbl |> - # # tidy up duplicated values in `project` and `table` + # # tidy up duplicated values in `project` and `asset` # dplyr::mutate( # Project = unfill_vec(Project), # Data = unfill_vec(Data) diff --git a/R/safe-call-utils.R b/R/safe-call-utils.R new file mode 100644 index 0000000..bb34048 --- /dev/null +++ b/R/safe-call-utils.R @@ -0,0 +1,153 @@ +#' @export +as.data.frame.safe_call <- function(x, ...) { + data.frame( + package = x$package, + fx = x$fx, + argument = names(x$args), + value = vapply(x$args, toString, character(1)), + stringsAsFactors = FALSE + ) +} + +enrich_argument <- function(arg, registry, timestamp, session) { + if (!is.character(arg) || length(arg) != 1) { + return(arg) + } + + symbol <- resolve_symbol( + registry, + symbol = arg, + timestamp = timestamp, + session = session + ) + + if (is.null(symbol)) { + return(arg) + } + + safe_reference( + symbol = symbol$symbol, + symbol_id = symbol$id + ) +} + +enrich_call <- function(call, registry) { + # call$args <- lapply(call$args, resolve_argument, registry = registry) + call$args <- purrr::map( + call$args, + enrich_argument, + registry = registry, + timestamp = call$created_at, + session = call$session + ) + + call +} + +get_function <- function(info) { + if (is.null(info$package)) { + return( + tryCatch(get(info$fx, mode = "function"), error = function(e) NULL) + ) + } + + tryCatch( + get(info$fx, envir = asNamespace(info$package), mode = "function"), + error = function(e) NULL + ) +} + +parse_arguments <- function(fx_call, info, expand.dots = FALSE) { + supplied <- as.list(fx_call[-1]) + supplied_names <- names(supplied) + + # (attempt to) recover function object + fun_obj <- get_function(info) + + matched <- tryCatch( + if (is.null(fun_obj)) { + NULL + } else { + match.call( + definition = fun_obj, + call = fx_call, + expand.dots = expand.dots + ) + }, + error = function(e) NULL + ) + + if (is.null(matched)) { + # fall back to the supplied arguments if matching failed + matched <- supplied + + # attach arg names + if (is.null(supplied_names)) { + supplied_names <- rep("", length(supplied)) + } + missing <- supplied_names == "" + + supplied_names[missing] <- paste0("..", which(missing)) + + names(matched) <- supplied_names + } else { + matched <- as.list(matched[-1]) + } + + # evaluate constants only + matched <- lapply(matched, simplify_argument) + + matched +} + +parse_call <- function(fx_call) { + fx <- fx_call[[1]] + + # package + function + info <- parse_function(fx) + + # arguments + args <- parse_arguments(fx_call, info) + + list( + original = paste(deparse(fx_call), collapse = ""), + package = info$package, + namespace = info$namespace, + fx = info$fx, + args = args + ) +} + +parse_function <- function(fx) { + if (is.call(fx) && identical(fx[[1]], as.name("::"))) { + return( + list( + package = as.character(fx[[2]]), + namespace = "::", + fx = as.character(fx[[3]]) + ) + ) + } + + list( + package = NULL, + namespace = NULL, + fx = as.character(fx) + ) +} + +simplify_argument <- function(x) { + if (is.atomic(x) || is.character(x)) { + return(x) + } + + if (is.name(x)) { + return(as.character(x)) + } + + if (is.call(x)) { + return(paste(deparse(x), collapse = "")) + } + + x +} diff --git a/R/safe-call.R b/R/safe-call.R new file mode 100644 index 0000000..e6d8491 --- /dev/null +++ b/R/safe-call.R @@ -0,0 +1,58 @@ +#' @export +as.data.frame.safe_call <- function(x, ...) { + data.frame( + timestamp = format(x$created_at, '%Y-%m-%dT%H:%M:%S'), + user = x$user, + r_cmd = x$original, + fx = paste0(x$package, x$namespace, x$fx), + args = x$args, + session = x$session, + profile = x$profile, + stringsAsFactors = FALSE + ) +} + +new_safe_call <- function( + original, + package, + namespace, + fx, + args, + ... +) { + stopifnot(is.character(original)) + stopifnot(is.character(fx)) + stopifnot(is.list(args)) + + structure( + list( + original = original, + package = package, + namespace = namespace, + fx = fx, + args = args, + created_at = getElement(list(...), "@timestamp"), + user = getElement(list(...), "username"), + session = getElement(list(...), "ds_id"), + profile = getElement(list(...), "ds_profile") + ), + class = "safe_call" + ) +} + +safe_call <- function(call, ...) { + UseMethod("safe_call") +} + +#' @export +safe_call.character <- function(call, ...) { + expr <- str2lang(call) + safe_call(expr, ...) +} + +#' @export +safe_call.call <- function(call, ...) { + parsed <- parse_call(call) + + do.call(new_safe_call, c(parsed, list(...))) +} diff --git a/R/safe-reference.R b/R/safe-reference.R new file mode 100644 index 0000000..ee1aed0 --- /dev/null +++ b/R/safe-reference.R @@ -0,0 +1,10 @@ +safe_reference <- function(symbol, symbol_id, column = NULL) { + structure( + list( + symbol = symbol, + symbol_id = symbol_id, + column = column + ), + class = "safe_reference" + ) +} diff --git a/R/safe-symbol-utils.R b/R/safe-symbol-utils.R new file mode 100644 index 0000000..89e05c3 --- /dev/null +++ b/R/safe-symbol-utils.R @@ -0,0 +1,129 @@ +find_symbols <- function(expr) { + if (is.character(expr)) { + expr <- parse(text = expr)[[1]] + } + + recurse <- function(x) { + if (is.symbol(x)) { + return(list(list( + symbol = as.character(x), + column = NA_character_ + ))) + } + + if (!is.call(x)) { + return(list()) + } + + if (identical(x[[1]], quote(`$`))) { + lhs <- x[[2]] + out <- list(list( + symbol = as.character(lhs), + column = as.character(x[[3]]) + )) + + return(out) + } + + unlist( + lapply(as.list(x)[-1], recurse), + recursive = FALSE + ) + } + + refs <- recurse(expr) + refs <- Filter(\(x) !(x$symbol %in% c("base", "stats", "utils")), refs) + if (!length(refs)) { + return(NULL) + } + refs +} + +resolve_dependencies <- function(expr, registry) { + if (is.null(expr) || is.na(expr)) { + return(tibble::tibble()) + } + + refs <- find_symbols(expr) + + if (is.null(refs)) { + return(tibble::tibble()) + } + + purrr::map_dfr(refs, function(ref) { + sym <- lookup_symbol(ref$symbol, registry) + + tibble::tibble( + symbol_id = if (nrow(sym)) sym$id else NA_character_, + symbol = ref$symbol, + column = ref$column, + kind = if (nrow(sym)) sym$kind else NA_character_, + asset = if (nrow(sym)) sym$asset else NA_character_ + ) + }) +} + +resolve_provenance <- function(symbol_id, registry, visited = character()) { + # local bindings + id <- NULL + + if (symbol_id %in% visited) { + return(tibble::tibble()) + } + + sym <- registry$symbols |> + dplyr::filter(id == symbol_id) + + deps <- sym$depends_on[[1]] + + if (!nrow(deps)) { + return(tibble::tibble()) + } + + children <- + purrr::map_dfr( + deps$symbol_id, + resolve_provenance, + registry = registry, + visited = c(visited, symbol_id) + ) + + dplyr::bind_rows(deps, children) +} + +resolve_symbol_asset <- function(symbol_id, registry) { + # local binding + asset <- id <- kind <- NULL + + sym <- registry$symbols |> + dplyr::filter(id == !!symbol_id) + + if (!nrow(sym)) { + return(NA_character_) + } + + # direct asset + if (sym$kind %in% c("table", "resource")) { + return(sym$asset) + } + + # expression: follow dependencies + deps <- resolve_provenance( + symbol_id, + registry + ) + + if (!nrow(deps)) { + return(NA_character_) + } + + assets <- deps |> + dplyr::filter(kind %in% c("table", "resource")) |> + dplyr::pull(asset) + + if (!length(assets)) { + return(NA_character_) + } + + paste(unique(stats::na.omit(assets)), collapse = ";") +} diff --git a/R/safe-symbol.R b/R/safe-symbol.R new file mode 100644 index 0000000..efadd04 --- /dev/null +++ b/R/safe-symbol.R @@ -0,0 +1,77 @@ +as_tibble.safe_symbol <- function(x, ...) { + tibble::tibble( + id = x$id, + symbol = x$symbol, + version = x$version, + kind = x$kind, + asset = x$asset, + expr = x$expr, + depends_on = x$depends_on, + created_by = x$created_by, + created_at = x$created_at, + user = x$user, + session = x$session, + action = x$action #, + # metadata = x$metadata, + # stringsAsFactors = FALSE + ) +} + +new_safe_symbol <- function( + symbol, + version = -999, + kind = "unknown", + asset = NA_character_, + expr = NA_character_, + depends_on = list(), + created_by = NA_character_, + created_at = Sys.time(), + user = NA_character_, + session = NA_character_, + action = NA_character_, + metadata = list(), + id = paste0("symbol-", uuid::UUIDgenerate()) +) { + stopifnot(is.character(symbol)) + stopifnot(length(symbol) == 1) + + structure( + list( + id = id, + symbol = symbol, + version = version, + kind = kind, + asset = asset, + expr = expr, + depends_on = depends_on, + created_by = created_by, + created_at = created_at, + user = user, + session = session, + action = action, + metadata = metadata + ), + class = "safe_symbol" + ) +} + +new_safe_symbol_reference <- function(symbol, column = NULL) { + stopifnot(is.character(symbol)) + stopifnot(length(symbol) == 1) + + structure( + list( + symbol = symbol, + column = column + ), + class = "safe_symbol_reference" + ) +} + +safe_symbol <- function(symbol, ...) { + new_safe_symbol(symbol = symbol, ...) +} + +safe_symbol_reference <- function(symbol, ...) { + new_safe_symbol_reference(symbol = symbol, ...) +} diff --git a/R/safe_data.R b/R/safe_data.R index 738f02a..00f185a 100644 --- a/R/safe_data.R +++ b/R/safe_data.R @@ -15,7 +15,7 @@ #' #' #' @param x This can be a connection to a 'DataSHIELD' server (e.g., object with -#' the `opal` class, see [opalr::opal.login()]), an RO-Crate +#' the `opal` or `ArmadilloCredentials` classes), an RO-Crate #' ([rocrate][rocrateR::rocrate()] class) or a string with the path to an #' RO-Crate. #' @param ... Other optional arguments. See the full documentation, @@ -40,6 +40,7 @@ safe_data <- function(x, ...) { UseMethod("safe_data") } +# @rdname safe_data #' @export safe_data.default <- function(x, ...) { stop( @@ -48,6 +49,15 @@ safe_data.default <- function(x, ...) { ) } +#' @rdname safe_data +#' @export +safe_data.ArmadilloCredentials <- function(x, ...) { + stop( + "`safe_data()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname safe_data #' @export safe_data.character <- function( diff --git a/R/safe_output.R b/R/safe_output.R index 112f6bf..42055f8 100644 --- a/R/safe_output.R +++ b/R/safe_output.R @@ -33,6 +33,7 @@ safe_output <- function(x, ...) { UseMethod("safe_output") } +# @rdname safe_output #' @export safe_output.default <- function(x, ...) { stop( @@ -41,6 +42,15 @@ safe_output.default <- function(x, ...) { ) } +#' @rdname safe_output +#' @export +safe_output.ArmadilloCredentials <- function(x, ...) { + stop( + "`safe_output()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname safe_output #' @export safe_output.character <- function( @@ -93,7 +103,8 @@ safe_output.opal <- function( # local bindings `@timestamp` <- backend <- logger_name <- safe_people_id <- username <- NULL ds_action <- ds_eval <- ds_id <- ds_function <- ds_symbol <- ds_table <- NULL - is_placeholder <- NULL + asset <- action <- is_placeholder <- kind <- symbol_id <- timestamp <- NULL + expr <- fx <- log_id <- r_cmd <- session <- symbol <- NULL # create formatted versions of input dates logs_from_is_valid <- FALSE @@ -200,8 +211,11 @@ safe_output.opal <- function( return(rocrate) } + # initialise symbol registry + registry <- symbol_registry() + # parse logs - userlogs_tbl <- opalr::dsadmin.log(x) |> + userlogs_tbl <- backend_logs(x) |> tibble::as_tibble() |> dplyr::mutate( `@timestamp` = as.POSIXct(`@timestamp`, format = "%Y-%m-%dT%H:%M:%S") @@ -210,6 +224,7 @@ safe_output.opal <- function( dplyr::filter(`@timestamp` >= logs_from, `@timestamp` <= logs_to) |> dplyr::filter(logger_name == "datashield.user") |> dplyr::filter(username %in% user) + userlogs <- NULL if (nrow(userlogs_tbl) > 0) { userlogs <- userlogs_tbl |> @@ -265,77 +280,197 @@ safe_output.opal <- function( encodingFormat = "text/plain" ) - # extract list of functions executed - ## evaluated functions and tables/symbols mapped - userlogs_tbl_maps_evals <- userlogs_tbl |> - dplyr::filter(ds_action %in% c("ASSIGN", "AGGREGATE", "OPEN")) |> - # add place-holder column, for when ro records are found - dplyr::bind_rows(tibble::tibble(ds_table = NA, is_placeholder = TRUE)) |> - dplyr::filter(is.na(is_placeholder)) |> - # create derived `ds_eval` when `ds_action` = 'ASSIGN' + # update symbol registry + ## extract 'ASSIGN' operations from the logs + userlogs_assign_tbl <- userlogs_tbl |> + dplyr::filter(ds_action %in% c("ASSIGN")) + + ## reshape the logs into a tibble of `symbols` + symbols_tbl <- seq_len(nrow(userlogs_assign_tbl)) |> + purrr::map(function(i) { + # extract log components + ds_eval <- getElement(userlogs_assign_tbl[i, ], "ds_eval") + ds_resource <- getElement(userlogs_assign_tbl[i, ], "ds_resource") + ds_symbol <- getElement(userlogs_assign_tbl[i, ], "ds_symbol") + ds_table <- getElement(userlogs_assign_tbl[i, ], "ds_table") + + # evaluate which fields are populated + is_expr <- !is.null(ds_eval) && !is.na(ds_eval) + is_resource <- !is.null(ds_resource) && !is.na(ds_resource) + is_table <- !is.null(ds_table) && !is.na(ds_table) + + tibble::tibble( + symbol = ds_symbol, + kind = ifelse( + is_expr, + 'expression', + ifelse( + is_resource, + 'resource', + ifelse(is_table, 'table', NA_character_) + ) + ), + asset = ifelse( + is_resource, + ds_resource, + ifelse(is_table, ds_table, NA_character_) + ), + expr = ifelse(is_expr, ds_eval, NA_character_), + # expr = if (is_expr) str2lang(ds_eval) else NULL, + created_by = ifelse( + is_expr, + 'DSI::datashield.assign.expr', + ifelse( + is_resource, + 'DSI::datashield.assign.resource', + ifelse(is_table, 'DSI::datashield.assign.table', NA_character_) + ) + ), + created_at = userlogs_assign_tbl$`@timestamp`[[i]], + user = userlogs_assign_tbl$username[[i]], + action = userlogs_assign_tbl$ds_action[[i]], + session = userlogs_assign_tbl$ds_id[[i]] + ) + }) |> + purrr::list_c() |> + dplyr::distinct() + + ## add symbols to registry + registry <- symbols_tbl |> + purrr::pmap(safe_symbol) |> + purrr::reduce(register_symbol, .init = registry) + + # parse aggregate function calls into list of safe_call objects + calls_lst <- userlogs_tbl |> + dplyr::filter((ds_action %in% c("AGGREGATE"))) |> + # dplyr::filter(!is.na(ds_eval)) |> + purrr::pmap(function(ds_eval, ...) { + safe_call(ds_eval, ...) |> + enrich_call(registry = registry) + }) + + # convert list of calls into tibble + calls_tbl <- purrr::map(calls_lst, \(x) { + tibble::tibble( + timestamp = format(x$created_at, '%Y-%m-%dT%H:%M:%S'), + action = "AGGREGATE", + user = x$user, + r_cmd = x$original, + fx = paste0(x$package, x$namespace, x$fx), + args = list(x$args), + symbol = NA, + table = x$args |> + purrr::map(function(x) { + if (!inherits(x, "safe_reference")) { + return(NA_character_) + } + resolve_symbol_asset(x$symbol_id, registry) + }), + session = x$session, + profile = x$profile + ) + }) |> + purrr::list_c() + + # combine function calls with symbol's registry + calls_symbols_tbl <- calls_tbl |> + dplyr::select(-symbol) |> dplyr::mutate( - ds_eval = dplyr::coalesce( - ds_eval, - paste0(ds_symbol, " <- opal[", ds_table, "]") - ), - # attach session ID, `ds_id`, if `ds_eval` if `ds_action == 'OPEN'` - ds_eval = ifelse( - ds_action == "OPEN", - paste0("Open session: ", ds_id), - ds_eval + args = purrr::map( + args, + ~ purrr::imap_dfr(.x, function(arg, nm) { + if (!inherits(arg, "safe_reference")) { + tibble::tibble( + argument = nm, + value = list(arg), + symbol_id = NA_character_, + symbol = NA_character_, + column = NA_character_ + ) + } else { + tibble::tibble( + argument = nm, + value = list(arg), + symbol_id = arg$symbol_id, + symbol = arg$symbol, + column = arg$column + ) + } + }) ) ) |> - dplyr::distinct( - ds_id, - username, - ds_action, - ds_eval, - ds_table, - `@timestamp` + (\(x) { + purrr::map2( + split(x |> dplyr::select(-args), seq_len(nrow(x))), + x$args, + dplyr::bind_cols + ) + })() |> + purrr::list_c() |> + dplyr::left_join( + registry$symbols, + by = c("symbol_id" = "id"), + suffix = c("", "_registry") ) |> - # refill values for ds_table, based on ds_id - dplyr::group_by(ds_id) |> dplyr::mutate( - ds_table = refill_vec(ds_table) + asset = dplyr::if_else( + kind == "expression", + purrr::map_chr( + symbol_id, + resolve_symbol_asset, + registry = registry + ), + asset + ) ) |> - dplyr::ungroup() |> + # add column with backend + dplyr::mutate(backend = "OBiBa's Opal") |> + # subset columns + dplyr::select( + timestamp, + action, + user, + r_cmd, + fx, + symbol, + kind, + asset, + expr, + # table = ds_table, + session, + backend + ) + + # extract session details + session_tbl <- userlogs_tbl |> + dplyr::filter((ds_action %in% c("OPEN"))) |> dplyr::mutate( # format timestamp - `@timestamp` = format(`@timestamp`, '%Y-%m-%dT%H:%M:%S'), - # extract function name from ds_eval - ds_function = ds_eval |> - gsub(pattern = "(?=\\().*$", replacement = "", perl = TRUE), - # extract symbol/object from ds_eval - ds_symbol = ds_eval |> - gsub(pattern = "^.*(?<=\\()", replacement = "", perl = TRUE) |> - gsub(pattern = "(?=\\)).*$", replacement = "", perl = TRUE) |> - gsub(pattern = '"|\'', replacement = "", perl = TRUE) |> - gsub(pattern = "(?=\\$).*", replacement = "", perl = TRUE), - # autofill `ds_function` when `ds_action` = 'ASSIGN' - ds_function = ifelse(ds_symbol == ds_eval, "base::assign", ds_function), - # set `ds_function = 'DSI::datashield.login'` if `ds_action == 'OPEN'` - ds_function = ifelse( - ds_action == "OPEN", - "DSI::datashield.login", - ds_function - ), - ds_symbol = ifelse(ds_symbol == ds_eval, NA, ds_symbol), - # add column with backend - backend = "OBiBa's Opal", - .before = 1 + timestamp = format(`@timestamp`, '%Y-%m-%dT%H:%M:%S'), + # attach session ID, `ds_id`, if `ds_action == 'OPEN'` + ds_eval = paste0("Open session: ", ds_id), + # set `ds_function = 'DSI::datashield.login'` + ds_function = "DSI::datashield.login", + backend = "OBiBa's Opal" ) |> dplyr::select( - timestamp = `@timestamp`, + timestamp, action = ds_action, user = username, r_cmd = ds_eval, fx = ds_function, - symbol = ds_symbol, - table = ds_table, session = ds_id, backend ) + # combine the logs + userlogs_tbl_maps_evals <- calls_symbols_tbl |> + dplyr::distinct() |> + dplyr::mutate(log_id = dplyr::row_number()) |> + dplyr::bind_rows(session_tbl) |> + dplyr::arrange(timestamp, log_id) |> + dplyr::select(-log_id) + log_maps_filename <- paste0( format(Sys.time(), "%Y%m%dT%H%M%S"), "-dslogs-", diff --git a/R/safe_people.R b/R/safe_people.R index 6203557..c212541 100644 --- a/R/safe_people.R +++ b/R/safe_people.R @@ -30,6 +30,7 @@ safe_people <- function(x, ...) { UseMethod("safe_people") } +# @rdname safe_people #' @export safe_people.default <- function(x, ...) { stop( @@ -38,6 +39,15 @@ safe_people.default <- function(x, ...) { ) } +#' @rdname safe_people +#' @export +safe_people.ArmadilloCredentials <- function(x, ...) { + stop( + "`safe_people()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname safe_people #' @export safe_people.character <- function( diff --git a/R/safe_project.R b/R/safe_project.R index 760645a..722ac69 100644 --- a/R/safe_project.R +++ b/R/safe_project.R @@ -22,28 +22,11 @@ #' \item Research Data Scotland, 2025. "What is the Five Safes framework?". #' #' } -#' -#' @aliases safe_project,armadillo-method -#' @usage -#' \S4method{safe_project}{armadillo}( -#' x, -#' ..., -#' profile = "default", -#' project = NULL, -#' rocrate = rocrateR::rocrate_5s(), -#' asset_id_suffix = "#asset:", -#' project_id_suffix = "#project:", -#' path = NULL, -#' resources = NULL, -#' tables = NULL, -#' user = NULL -#' ) safe_project <- function(x, ...) { UseMethod("safe_project") } -# S3 methods ---- -#' @method safe_project default +# @rdname safe_project #' @export safe_project.default <- function(x, ...) { stop( @@ -52,7 +35,31 @@ safe_project.default <- function(x, ...) { ) } -#' @method safe_project character +#' @rdname safe_project +#' @export +safe_project.ArmadilloCredentials <- function( + x, + ..., + profile = "default", + project = NULL, + rocrate = rocrateR::rocrate_5s(), + asset_id_suffix = "#asset:", + project_id_suffix = "#project:", + path = NULL, + resources = NULL, + tables = NULL, + user = NULL +) { + # check if the given `project` exists + project_exists(x, project = project) + + # retrieve details associated to `project` + project_details_tbl <- MolgenisArmadillo::armadillo.get_projects_info() |> + purrr::map(\(x) tibble::tibble(name = x$name, users = unlist(x$users))) |> + purrr::list_c() + project_details_tbl +} + #' @rdname safe_project #' @export safe_project.character <- function( @@ -86,7 +93,6 @@ safe_project.character <- function( ) } -#' @method safe_project opal #' @rdname safe_project #' @export safe_project.opal <- function( @@ -122,7 +128,7 @@ safe_project.opal <- function( project_id <- id_hash(project_id_suffix, project) # retrieve details associated to `project` - project_details_tbl <- opalr::opal.project(x, project) + project_details_tbl <- backend_project(x, project) # filter out asset entities associated with the project based on the # value for `asset_id_suffix`. @@ -149,7 +155,7 @@ safe_project.opal <- function( rocrateR::add_entity(project_entity, overwrite = TRUE) # Opal permissions ---- - perms <- opalr::opal.project_perm(x, project) + perms <- backend_project_perms(x, project) project_users <- perms |> dplyr::filter(type == "user") |> @@ -209,7 +215,6 @@ safe_project.opal <- function( return(rocrate) } -#' @method safe_project rocrate #' @rdname safe_project #' @export safe_project.rocrate <- function( @@ -244,29 +249,3 @@ safe_project.rocrate <- function( user = user ) } - -# S4 methods ---- -#' @method safe_project ArmadilloCredentials -#' @rdname safe_project -#' @export -safe_project.ArmadilloCredentials <- function( - x, - ..., - profile = "default", - project = NULL, - rocrate = rocrateR::rocrate_5s(), - asset_id_suffix = "#asset:", - project_id_suffix = "#project:", - path = NULL, - resources = NULL, - tables = NULL, - user = NULL -) { - # check if the given `project` exists - project_exists(x, project = project) - - # retrieve details associated to `project` - project_details_tbl <- MolgenisArmadillo::armadillo.get_projects_info() |> - purrr::list_c() |> - tibble::as_tibble() -} diff --git a/R/safe_setting.R b/R/safe_setting.R index b729044..c13638c 100644 --- a/R/safe_setting.R +++ b/R/safe_setting.R @@ -35,6 +35,7 @@ safe_setting <- function(x, ...) { UseMethod("safe_setting") } +# @rdname safe_setting #' @export safe_setting.default <- function(x, ...) { stop( @@ -43,6 +44,15 @@ safe_setting.default <- function(x, ...) { ) } +#' @rdname safe_setting +#' @export +safe_setting.ArmadilloCredentials <- function(x, ...) { + stop( + "`safe_setting()` for the Armadillo backend is not currently implemented!", + call. = FALSE + ) +} + #' @rdname safe_setting #' @export safe_setting.character <- function( @@ -154,7 +164,7 @@ safe_setting.opal <- function( validate_backend(x, ...) # validate profile ---- - if (!opalr::dsadmin.profile_exists(x, profile)) { + if (!backend_profile_exists(x, profile)) { stop( sprintf("The given profile name, `%s`, does not exist!", profile), call. = FALSE @@ -163,7 +173,7 @@ safe_setting.opal <- function( # statistical disclosure controls ---- # extract disclosure settings and create `PropertyValue` entities - disc_setting_entities <- opalr::dsadmin.get_options(x, profile = profile) |> + disc_setting_entities <- backend_options(x, profile = profile) |> tibble::as_tibble() |> purrr::pmap(function(name, value, ...) { rocrateR::entity( @@ -190,7 +200,7 @@ safe_setting.opal <- function( # computational environment ---- # extract information about R packages installed in the environment - pkg_tbl <- opalr::dsadmin.package_descriptions(x) |> + pkg_tbl <- backend_packages(x) |> tibble::as_tibble() pkg_entities <- pkg_tbl |> purrr::pmap(function(Package, Version, Description, Author, ...) { diff --git a/R/symbol-registry.R b/R/symbol-registry.R new file mode 100644 index 0000000..b0062ee --- /dev/null +++ b/R/symbol-registry.R @@ -0,0 +1,120 @@ +#' @export +as.data.frame.symbol_registry <- function(x, ...) { + do.call( + rbind, + lapply( + x$symbols, + function(sym) { + data.frame( + symbol = sym$symbol, + kind = sym$kind, + asset = sym$asset, + parent = sym$parent, + column = sym$column, + stringsAsFactors = FALSE + ) + } + ) + ) +} + +has_symbol <- function(registry, name) { + UseMethod("has_symbol") +} + +#' @export +has_symbol.symbol_registry <- function(registry, name) { + name %in% names(registry$symbols) +} + +new_symbol_registry <- function(symbols = list()) { + structure( + list( + symbols = symbols + ), + class = "symbol_registry" + ) +} + +lookup_symbol <- function(symbol, registry, session = NULL) { + out <- registry$symbols + + if (!is.null(session)) { + out <- dplyr::filter(out, session == !!session) + } + + out |> + dplyr::filter(symbol == !!symbol) |> + dplyr::arrange(dplyr::desc(version)) |> + dplyr::slice(1) +} + +register_symbol <- function(registry, symbol) { + # local bindings + aux <- session <- NULL + stopifnot(inherits(symbol, "safe_symbol")) + + # extract current version of symbol + if (nrow(registry$symbols) == 0 || length(registry$symbols) == 0) { + current_version <- 0 + } else { + aux <- registry$symbols |> + dplyr::filter( + session == !!symbol$session, + symbol == !!symbol$symbol + ) + if (nrow(aux)) { + current_version <- aux |> + dplyr::summarise( + version = dplyr::coalesce(max(version), 0L) + ) |> + dplyr::pull(version) + } else { + current_version <- 0 + } + } + + symbol$version <- current_version + 1L + + symbol$depends_on <- list(resolve_dependencies(symbol$expr, registry)) + + registry$symbols <- dplyr::bind_rows( + registry$symbols, + tibble::as_tibble(symbol) + ) + + registry +} + +resolve_symbol <- function( + registry, + symbol, + timestamp, + session = NULL, + user = NULL +) { + # local binding + created_at <- NULL + + x <- registry$symbols |> + dplyr::filter(symbol == !!symbol, created_at <= !!timestamp) + + if (!is.null(session)) { + x <- dplyr::filter(x, session == !!session) + } + + if (!is.null(user)) { + x <- dplyr::filter(x, user == !!user) + } + + if (nrow(x) == 0) { + return(NULL) + } + + x |> + dplyr::slice_max(created_at, n = 1) +} + +symbol_registry <- function() { + new_symbol_registry() +} diff --git a/R/utils-armadillo.R b/R/utils-armadillo.R index 4f146f1..a9f2068 100644 --- a/R/utils-armadillo.R +++ b/R/utils-armadillo.R @@ -7,6 +7,11 @@ #' #' @returns MOLGENIS' Armadillo connection object. #' @export +#' +#' @examples +#' \dontrun{ +#' armadillo_login("https://armadillo-playground.molgenis.net/") +#' } armadillo_login <- function(server) { conn <- DSMolgenisArmadillo::armadillo.get_credentials(server) ns <- loadNamespace("MolgenisArmadillo") diff --git a/R/utils-audit.R b/R/utils-audit.R index 5be4ee8..9897da6 100644 --- a/R/utils-audit.R +++ b/R/utils-audit.R @@ -1,3 +1,19 @@ +#' Audit intent of study +#' +#' This internal helper is used to audit and object containing details about the +#' 'intent' of a study. Details include server configuration, user credentials, +#' project and associated assets (e.g., tables and resources). +#' +#' @param excluded_args Vector with names of args to be excluded from the main +#' audit call. +#' @param ... Additional args to be used in the audit process. +#' +#' @inheritParams audit intent +#' +#' @returns List with two audit objects, one for the intent and one for the main +#' @keywords internal +#' +#' @noRd audit_intent <- function(intent, excluded_args = c("project", "user"), ...) { # if `intent` is NOT NULL, audit this object intent_audit <- if (!is.null(intent)) { @@ -29,6 +45,15 @@ audit_intent <- function(intent, excluded_args = c("project", "user"), ...) { list(intent_audit = intent_audit, main_audit_args = main_audit_args) } +#' Excluded arguments from a list +#' +#' @param ... List with arguments. +#' @param excluded Vector with names of args to be excluded from the input list. +#' +#' @returns List with arguments after filtering the values in `excluded`. +#' @keywords internal +#' +#' @noRd exclude_args <- function(..., excluded) { # capture additional args args <- list(...) @@ -36,3 +61,17 @@ exclude_args <- function(..., excluded) { # exclude args that shouldn't be passed to the next function args[!(arg_names %in% excluded)] } + +#' Wrapper for [tryCatch] +#' +#' @param expr R code to be executed inside `tryCatch`. +#' @param error_val Value to be returned on failure. +#' +#' @returns List with value and any resulting error. +#' @noRd +.try_load <- function(expr, error_val = NULL) { + tryCatch( + list(value = expr, error = NULL), + error = function(e) list(value = error_val, error = conditionMessage(e)) + ) +} diff --git a/R/utils-connection.R b/R/utils-connection.R index ea4a579..c7222e1 100644 --- a/R/utils-connection.R +++ b/R/utils-connection.R @@ -15,7 +15,11 @@ parse_user_profiles <- function(x, ...) { UseMethod("parse_user_profiles") } -# S3 methods ---- +#' @export +parse_user_profiles.ArmadilloCredentials <- function(x, ..., user) { + message("PLACEHOLDER!") +} + #' @export #' @family Opal parse_user_profiles.opal <- function(x, ..., user) { @@ -23,7 +27,7 @@ parse_user_profiles.opal <- function(x, ..., user) { principal <- userInfo <- NULL # get user profiles and filter by the current user - user_prof_tbl <- opalr::oadmin.user_profiles(x, df = FALSE) |> + user_prof_tbl <- backend_users(x, df = FALSE) |> dplyr::bind_rows() |> dplyr::filter(principal %in% user) # extract (if available) `userInfo` which contains additional details @@ -45,17 +49,8 @@ parse_user_profiles.opal <- function(x, ..., user) { return(user_prof_tbl) } -# S4 methods ---- -#' @export -parse_user_profiles.ArmadilloCredentials <- function(x, ..., user) { - message("PLACEHOLDER!") -} - #' Verify if project exists #' -#' Wrapper for the [opalr::opal.project_exists()] and -#' [MolgenisArmadillo::armadillo.list_projects()] functions. -#' #' @param x Connection object to backend for DataSHIELD server (e.g., Opal). #' @param ... Optional arguments, unused. #' @param project String with project name to be verified. @@ -69,22 +64,6 @@ project_exists <- function(x, ...) { UseMethod("project_exists") } -# S3 methods ---- -#' @export -#' @family Opal -project_exists.opal <- function(x, ..., project) { - if (!opalr::opal.project_exists(x, project)) { - stop( - sprintf( - "The `project = '%s'` was not found in the given Opal connection!", - project - ), - call. = FALSE - ) - } -} - -# S4 methods ---- #' @export #' @family Armadillo project_exists.ArmadilloCredentials <- @@ -104,6 +83,20 @@ project_exists.ArmadilloCredentials <- } } +#' @export +#' @family Opal +project_exists.opal <- function(x, ..., project) { + if (!backend_project_exists(x, project)) { + stop( + sprintf( + "The `project = '%s'` was not found in the given Opal connection!", + project + ), + call. = FALSE + ) + } +} + #' Validate backend #' #' Validate backend: including connection status, backend version and check the @@ -125,74 +118,3 @@ validate_backend <- function(x, ...) { invisible(TRUE) } - -#' Validate backend version -#' -#' @param x DataSHIELD backend connection object. -#' @param ... Unused. -#' @param minimum String with minimum version. -#' -#' @returns Logical value indicating if backend version is valid. -#' @keywords internal -#' @noRd -validate_backend_version <- function(x, ...) { - UseMethod("validate_backend_version") -} - -#' @export -validate_backend_version.default <- function(x, ...) { - invisible(TRUE) -} - -#' @export -validate_backend_version.opal <- function(x, ..., minimum = "5.7.2") { - if (utils::compareVersion(x$version, minimum) < 0) { - stop( - sprintf( - "Opal >= %s is required, but server version is %s.", - minimum, - x$version - ), - call. = FALSE - ) - } - invisible(TRUE) -} - -#' Validate backend connection -#' -#' @param x DataSHIELD backend connection object. -#' @param ... Unused. -#' -#' @returns Nothing, call for its side effect. -#' @keywords internal -#' @noRd -validate_con <- function(x, ...) { - UseMethod("validate_con") -} - -#' @export -validate_con.default <- function(x, ...) { - stop( - sprintf( - "Unsupported connection type: %s", - paste(class(x), collapse = ", ") - ), - call. = FALSE - ) -} - -#' @export -validate_con.opal <- function(x, ...) { - tryCatch( - { - status <- xptr::is_null_xptr(x$handle$handle) - if (status) { - stop("The given connection is not valid!", call. = FALSE) - } - }, - error = function(e) { - stop("The given connection is not valid!", call. = FALSE) - } - ) -} diff --git a/R/utils-cr8tor.R b/R/utils-cr8tor.R index 028cc6f..05b3b0d 100644 --- a/R/utils-cr8tor.R +++ b/R/utils-cr8tor.R @@ -189,6 +189,13 @@ add_permission_entities_cr8tor <- function(rc, perm_expanded_tbl) { rc } +#' Add Safe Setting entities +#' +#' @param rc RO-Crate object, see [rocrateR::rocrate]. +#' @param tbl Tibble with settings details. +#' +#' @return Updated RO-Crate +#' @noRd add_safe_setting_entities_cr8tor <- function(rc, tbl) { for (i in seq_len(nrow(tbl))) { nm <- names(tbl)[i] @@ -207,6 +214,13 @@ add_safe_setting_entities_cr8tor <- function(rc, tbl) { rc } +#' Add Safe Output entities +#' +#' @param rc RO-Crate object, see [rocrateR::rocrate]. +#' @param tbl Tibble with settings details. +#' +#' @return Updated RO-Crate +#' @noRd add_safe_output_entities_cr8tor <- function(rc, tbl) { rc |> rocrateR::add_entity( @@ -292,7 +306,6 @@ as_rocrate_audit <- function(audit) { rc } - #' Keep strongest permission per user-asset pair #' #' @param perm_tbl Tibble with username, asset, permission. @@ -519,6 +532,11 @@ extract_safe_people_cr8tor <- function(bundle) { list(users = users, n_users = nrow(users)) } +#' Extract user's groups +#' +#' @param bundle cr8tor_bundle +#' @return tibble(username, group) +#' @noRd extract_user_groups_cr8tor <- function(bundle) { user_docs <- bundle$resources[ grepl("user-.*\\.ya?ml$", names(bundle$resources)) @@ -543,6 +561,11 @@ extract_user_groups_cr8tor <- function(bundle) { purrr::list_c() } +#' Extract user's projects +#' +#' @param bundle cr8tor_bundle +#' @return tibble(username, project) +#' @noRd extract_user_projects_cr8tor <- function(bundle) { # local bindings description <- group_id <- NULL @@ -581,6 +604,11 @@ extract_user_projects_cr8tor <- function(bundle) { dplyr::distinct() } +#' Extract groups +#' +#' @param bundle cr8tor_bundle +#' @return tibble(group_id, description, project) +#' @noRd extract_groups_cr8tor <- function(bundle) { grp_docs <- bundle$resources[ grepl("group-.*\\.ya?ml$", names(bundle$resources)) @@ -651,6 +679,11 @@ extract_permissions_cr8tor <- function(bundle) { purrr::list_c() } +#' Extract projects +#' +#' @param bundle cr8tor_bundle +#' @return tibble(project, description) +#' @noRd extract_projects_cr8tor <- function(bundle) { prj_docs <- bundle$resources[ grepl("project-.*\\.ya?ml$", names(bundle$resources)) @@ -733,6 +766,14 @@ find_bagit_root <- function(path) { return(NULL) } +#' Link people entities to the RO-Crate root +#' +#' @param rc RO-Crate object, see [rocrateR::rocrate]. +#' @param usernames Vector of strings with usernames. +#' +#' @returns Updated RO-Crate +#' @keywords internal +#' @noRd link_people_to_root <- function(rc, usernames) { authors <- lapply(usernames, \(u) { list(`@id` = id_hash("#person:", u)) @@ -764,17 +805,31 @@ load_cr8tor_bundle <- function(x, ...) { tmp <- tempfile("cr8tor_") dir.create(tmp, recursive = TRUE, showWarnings = FALSE) - utils::unzip(x, exdir = tmp) + ok <- tryCatch( + { + utils::unzip(x, exdir = tmp) + TRUE + }, + warning = function(w) FALSE, + error = function(e) FALSE + ) + + if (!ok) { + stop("Not a valid cr8tor bundle.", call. = FALSE) + } + + # get root directory for bag + bagit_root <- find_bagit_root(tmp) # load RO-Crate layer rocrate <- rocrateR::load_rocrate( - x, #file.path(tmp, "bagit"), + bagit_root, load_content = TRUE, ... ) - tmp_root <- find_bagit_root(tmp) |> - dirname() + # get base dir + tmp_root <- dirname(bagit_root) # parse resources layer res_dir <- file.path(tmp_root, "resources") @@ -804,6 +859,15 @@ load_cr8tor_bundle <- function(x, ...) { ) } +#' Map project name to ID +#' +#' @param project String with project name. +#' @param proj_tbl Tibble with projects' details. +#' +#' @returns Project ID if one is matched to the given `project` +#' @keywords internal +#' +#' @noRd map_project_name_to_id <- function(project, proj_tbl) { idx <- which(proj_tbl$description == project) if (length(idx) == 0) { diff --git a/R/utils-opal.R b/R/utils-opal.R index d049085..287d776 100644 --- a/R/utils-opal.R +++ b/R/utils-opal.R @@ -127,7 +127,7 @@ build_asset_entities <- function(assets_tbl, project_id, asset_id_suffix) { #' Get project's asset permissions #' -#' @param x Connection to OBiBa's Opal server (see [opalr::opal.login()]). +#' @param x Connection to DataSHIELD server (e.g., OBiBa's Opal server). #' @param project String with project name. #' @param asset_type String with type of asset, either `tables` or `resources`. #' @param name String with asset name. @@ -136,9 +136,9 @@ build_asset_entities <- function(assets_tbl, project_id, asset_id_suffix) { #' @noRd get_asset_permissions <- function(x, project, asset_type, name) { if (asset_type == "table") { - perms <- opalr::opal.table_perm(x, project, name) + perms <- backend_table_perms(x, project, name) } else { - perms <- opalr::opal.resource_perm(x, project, name) + perms <- backend_resource_perms(x, project, name) } if (is.null(perms) || length(perms$subject) == 0) { @@ -153,7 +153,7 @@ get_asset_permissions <- function(x, project, asset_type, name) { #' Get project assets. #' -#' @param x Connection to OBiBa's Opal server (see [opalr::opal.login()]). +#' @param x Connection to DataSHIELD server (e.g., OBiBa's Opal server). #' @param project String with project name. #' @param type Type of assets to extract, either `tables` or `resources`. #' @@ -166,7 +166,7 @@ get_project_assets <- function(x, project, type = c("tables", "resources")) { project_exists(x, project = project) if (type == "tables") { - prj <- opalr::opal.tables(x, project, df = FALSE) + prj <- backend_tables(x, project, df = FALSE) if (length(prj) == 0) { return(NULL) @@ -187,7 +187,7 @@ get_project_assets <- function(x, project, type = c("tables", "resources")) { meta = vector("list", length(prj)) ) } else if (type == "resources") { - res <- opalr::opal.resources(x, project, df = FALSE) + res <- backend_resources(x, project, df = FALSE) if (length(res) == 0) { return(NULL) @@ -282,92 +282,6 @@ infer_table_resource_lineage <- function(assets_tbl) { purrr::list_c() } -#' Verify if connection was created by an administrative user -#' -#' @inheritParams validate_con -#' -#' @returns Boolean flag to indicate whether the given connection was created -#' by an administrative user. -#' @keywords internal -#' -#' @noRd -is_opal_admin_con <- function(x) { - # local binding - aux <- NULL - - # condition 1: admin users have access to `opalr::oadmin.user_exists` - cond1 <- tryCatch( - { - aux <- opalr::oadmin.user_exists(x, x$username) - TRUE - }, - error = function(e) { - FALSE - } - ) - - # condition 2: admin users have access to `opalr::dsadmin.profile_exists` - cond2 <- tryCatch( - { - aux <- opalr::dsadmin.profile_exists(x, "default") - TRUE - }, - error = function(e) { - FALSE - } - ) - - # check all the conditions are met - if (all(cond1, cond2)) { - return(TRUE) - } else { - return(FALSE) - } -} - -#' Verify if connection was created by an auditor user -#' -#' @inheritParams validate_con -#' -#' @returns Boolean flag to indicate whether the given connection was created -#' by an administrative user. -#' @keywords internal -#' -#' @noRd -is_opal_audit_con <- function(x) { - # local binding - aux <- NULL - - # condition 1: auditor users don't have access to `opalr::oadmin.user_exists` - cond1 <- tryCatch( - { - aux <- opalr::oadmin.user_exists(x, x$username) - FALSE - }, - error = function(e) { - TRUE - } - ) - - # condition 2: auditor users have access to `opalr::dsadmin.profile_exists` - cond2 <- tryCatch( - { - aux <- opalr::dsadmin.profile_exists(x, "default") - TRUE - }, - error = function(e) { - FALSE - } - ) - - # check all the conditions are met - if (all(cond1, cond2)) { - return(TRUE) - } else { - return(FALSE) - } -} - #' @noRd link_assets_to_project <- function(rocrate, project_id, asset_ids) { proj_entity <- .get_entity(rocrate, id = project_id)[[1]] diff --git a/R/utils-safe_data.R b/R/utils-safe_data.R index feb3cd1..34056d0 100644 --- a/R/utils-safe_data.R +++ b/R/utils-safe_data.R @@ -16,7 +16,7 @@ extract_safe_data <- function(x, ...) { #' @export extract_safe_data.opal <- function(x, ..., rocrate = rocrateR::rocrate_5s()) { # extract list with all projects - ds <- opalr::opal.projects(x) + ds <- backend_projects(x) # extract project names and ignore NAs projects <- ds$name[!is.na(ds$name) & !is.null(ds$name)] diff --git a/R/utils-safe_people.R b/R/utils-safe_people.R index b03e172..1ccdb94 100644 --- a/R/utils-safe_people.R +++ b/R/utils-safe_people.R @@ -15,15 +15,8 @@ extract_safe_people <- function(x, ...) { #' @export extract_safe_people.opal <- function(x, ..., rocrate = rocrateR::rocrate_5s()) { - # set local binding - name <- principal <- NULL - - # extract all users - opal_users <- opalr::oadmin.user_profiles(x, df = FALSE) |> - dplyr::bind_rows() |> - dplyr::rename(name = principal) |> - # exclude system administrators from the report - dplyr::filter(!(tolower(name) %in% c("admin", "administrator"))) + # extract non-admin and non-auditor users + opal_users <- filter_safe_people(x) # cycle through the data source (x) and extract project details for (i in seq_len(nrow(opal_users))) { @@ -99,6 +92,66 @@ extract_safe_people.rocrate <- function( return(rocrate) } +#' Filter Safe People (excluding admin/auditor accounts) +#' +#' @inheritParams safe_data +#' +#' @returns Tibble with one row per non-admin, non-auditor user account, +#' accounting for permissions granted directly or via group membership. +#' @keywords internal +#' @noRd +filter_safe_people <- function(x, ...) { + UseMethod("filter_safe_people") +} + +#' @export +filter_safe_people.opal <- function(x, ...) { + # set local binding + name <- permission <- principal <- type <- NULL + + # extract all users + opal_users <- backend_users(x, df = FALSE) |> + dplyr::bind_rows() |> + dplyr::rename(name = principal) + + if (nrow(opal_users) == 0) { + return(tibble::tibble()) + } + + # permission lookups can fail independently of the user list (e.g. a + # transient server error) - fall back to an empty Safe People table + # rather than letting the failure propagate and abort the whole audit + tryCatch( + { + # extract system permissions + sys_perms_tbl <- backend_sys_perms(x) + + # user identities + user_identity <- opal_users |> + dplyr::transmute(name, subject = name, type = "user") + + # group identities + group_identity <- data.frame( + name = rep(opal_users$name, lengths(opal_users$groups)), + subject = unlist(opal_users$groups, use.names = FALSE), + type = "group", + stringsAsFactors = FALSE + ) + + identity_tbl <- dplyr::bind_rows(user_identity, group_identity) + + sys_perms_tbl |> + dplyr::right_join(identity_tbl, by = c("subject", "type")) |> + dplyr::right_join(opal_users, by = "name") |> + dplyr::filter(!(permission %in% c("administrate", "audit"))) |> + dplyr::filter(type == "user") + }, + error = function(e) { + tibble::tibble() + } + ) +} + #' Flatten object with Safe People details #' #' @param x Object (e.g., RO-Crate) with Safe People details. This can be diff --git a/R/utils-safe_project.R b/R/utils-safe_project.R index 8f58a22..7ecaefc 100644 --- a/R/utils-safe_project.R +++ b/R/utils-safe_project.R @@ -21,7 +21,7 @@ extract_safe_project.opal <- function( rocrate = rocrateR::rocrate_5s() ) { # extract list with all projects - ds <- opalr::opal.projects(x) + ds <- backend_projects(x) # cycle through the data source (x) and extract project details for (i in seq_len(nrow(ds))) { diff --git a/inst/WORDLIST b/inst/WORDLIST index 8540a5d..7b63e69 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -3,36 +3,29 @@ CMD DataSHIELD DataSHIELD’ Dumontier +FederatedMethods Lifecycle MOLGENIS OBiBa OBiBa's ORCID -OllyButters -POSIXct RO +RStudio Rmd SafePods Sci TRE TREs -Tibble -Unfill -bagit -com -cr +backends datashield +datasource doi etc -github -ies -issuecomment +hardcoded md org -pcr +regex sdata -tidyr -tidyverse -toml +tibble ’s -️NOTE +️ diff --git a/man/armadillo_login.Rd b/man/armadillo_login.Rd index 8bd8eb0..47c0376 100644 --- a/man/armadillo_login.Rd +++ b/man/armadillo_login.Rd @@ -16,3 +16,8 @@ MOLGENIS' Armadillo connection object. Login to a MOLGENIS' Armadillo server. Wrapper for the function \code{\link[DSMolgenisArmadillo:armadillo.get_credentials]{DSMolgenisArmadillo::armadillo.get_credentials()}}. } +\examples{ +\dontrun{ + armadillo_login("https://armadillo-playground.molgenis.net/") +} +} diff --git a/man/check_permissions.Rd b/man/check_permissions.Rd index 52076d7..75bea70 100644 --- a/man/check_permissions.Rd +++ b/man/check_permissions.Rd @@ -2,14 +2,23 @@ % Please edit documentation in R/check_permissions.R \name{check_permissions} \alias{check_permissions} +\alias{check_permissions.ArmadilloCredentials} +\alias{check_permissions.opal} \title{Check backend connection permissions} \usage{ check_permissions(x, ...) + +\method{check_permissions}{ArmadilloCredentials}(x, ...) + +\method{check_permissions}{opal}(x, ..., verbose = FALSE) } \arguments{ \item{x}{A backend connection object.} \item{...}{Additional arguments passed to methods.} + +\item{verbose}{Boolean value used to indicate if a success message should be +displayed (default: FALSE)} } \value{ Returns \code{TRUE} invisibly if the connection has sufficient permissions. diff --git a/man/init.Rd b/man/init.Rd index 646685f..44302ec 100644 --- a/man/init.Rd +++ b/man/init.Rd @@ -2,12 +2,15 @@ % Please edit documentation in R/dsROCrate.R \name{init} \alias{init} +\alias{init.ArmadilloCredentials} \alias{init.opal} \alias{init.rocrate} \title{Initialise a Five Safes RO-Crate} \usage{ init(x, ...) +\method{init}{ArmadilloCredentials}(x, ...) + \method{init}{opal}( x, ..., @@ -34,7 +37,7 @@ init(x, ...) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} diff --git a/man/report.Rd b/man/report.Rd index fcfa194..935952a 100644 --- a/man/report.Rd +++ b/man/report.Rd @@ -2,14 +2,16 @@ % Please edit documentation in R/report.R \name{report} \alias{report} +\alias{report.ArmadilloCredentials} \alias{report.character} -\alias{report.default} \alias{report.list} \alias{report.rocrate} \title{Create an RO-Crate report} \usage{ report(x, ...) +\method{report}{ArmadilloCredentials}(x, ...) + \method{report}{character}( x, ..., @@ -25,8 +27,6 @@ report(x, ...) max_line_length = 200 ) -\method{report}{default}(x, ...) - \method{report}{list}( x, ..., diff --git a/man/safe_data.Rd b/man/safe_data.Rd index b35ab00..018277c 100644 --- a/man/safe_data.Rd +++ b/man/safe_data.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/safe_data.R \name{safe_data} \alias{safe_data} +\alias{safe_data.ArmadilloCredentials} \alias{safe_data.character} \alias{safe_data.opal} \alias{safe_data.rocrate} @@ -15,6 +16,8 @@ \usage{ safe_data(x, ...) +\method{safe_data}{ArmadilloCredentials}(x, ...) + \method{safe_data}{character}( x, ..., @@ -60,7 +63,7 @@ safe_data(x, ...) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} diff --git a/man/safe_output.Rd b/man/safe_output.Rd index 91632fb..c05404c 100644 --- a/man/safe_output.Rd +++ b/man/safe_output.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/safe_output.R \name{safe_output} \alias{safe_output} +\alias{safe_output.ArmadilloCredentials} \alias{safe_output.character} \alias{safe_output.opal} \alias{safe_output.rocrate} @@ -15,6 +16,8 @@ \usage{ safe_output(x, ...) +\method{safe_output}{ArmadilloCredentials}(x, ...) + \method{safe_output}{character}( x, ..., @@ -59,7 +62,7 @@ safe_output(x, ...) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} diff --git a/man/safe_people.Rd b/man/safe_people.Rd index 651fb83..c1ca90f 100644 --- a/man/safe_people.Rd +++ b/man/safe_people.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/safe_people.R \name{safe_people} \alias{safe_people} +\alias{safe_people.ArmadilloCredentials} \alias{safe_people.character} \alias{safe_people.opal} \alias{safe_people.rocrate} @@ -15,6 +16,8 @@ \usage{ safe_people(x, ...) +\method{safe_people}{ArmadilloCredentials}(x, ...) + \method{safe_people}{character}( x, ..., @@ -62,7 +65,7 @@ safe_people(x, ...) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} diff --git a/man/safe_project.Rd b/man/safe_project.Rd index 3321e50..3e17ddb 100644 --- a/man/safe_project.Rd +++ b/man/safe_project.Rd @@ -2,11 +2,10 @@ % Please edit documentation in R/safe_project.R \name{safe_project} \alias{safe_project} -\alias{safe_project,armadillo-method} +\alias{safe_project.ArmadilloCredentials} \alias{safe_project.character} \alias{safe_project.opal} \alias{safe_project.rocrate} -\alias{safe_project.ArmadilloCredentials} \title{Safe Project details} \source{ \itemize{ @@ -15,7 +14,9 @@ } } \usage{ -\S4method{safe_project}{armadillo}( +safe_project(x, ...) + +\method{safe_project}{ArmadilloCredentials}( x, ..., profile = "default", @@ -70,24 +71,10 @@ tables = attr(x, "tables"), user = attr(x, "user") ) - -\method{safe_project}{ArmadilloCredentials}( - x, - ..., - profile = "default", - project = NULL, - rocrate = rocrateR::rocrate_5s(), - asset_id_suffix = "#asset:", - project_id_suffix = "#project:", - path = NULL, - resources = NULL, - tables = NULL, - user = NULL -) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} @@ -98,16 +85,16 @@ RO-Crate.} \item{project}{String with the name of the \link[=safe_project]{Safe Project}.} +\item{rocrate}{RO-Crate object. Optional, if \code{x} is either an RO-Crate +object or a path to a valid RO-Crate. If so, then \code{connection} is +required (default: \code{rocrateR::rocrate_5s()}).} + \item{asset_id_suffix}{String with ID suffix for the tables/datasets entities in the RO-Crate (default: \code{"#asset:"}).} \item{project_id_suffix}{String with ID suffix for the project entities in the RO-Crate (default: \code{"#project:"}).} -\item{connection}{Connection object for the 'DataSHIELD' server where the -values will be extracted from (e.g., OBiBa's Opal). Optional, if \code{x} is -set to a connection object. If so, then \code{rocrate} is required.} - \item{path}{String with path pointing to the root of the RO-Crate. This will be used to store log files. If not provided, logs will be stored within the RO-Crate returned by this function.} @@ -124,9 +111,9 @@ associated to \code{project} will be included in the RO-Crate.} the Safe People, it must include \verb{@id} and \code{name} entries. Alternatively, this can be a string with the \code{name} of the current user.} -\item{rocrate}{RO-Crate object. Optional, if \code{x} is either an RO-Crate -object or a path to a valid RO-Crate. If so, then \code{connection} is -required (default: \code{rocrateR::rocrate_5s()}).} +\item{connection}{Connection object for the 'DataSHIELD' server where the +values will be extracted from (e.g., OBiBa's Opal). Optional, if \code{x} is +set to a connection object. If so, then \code{rocrate} is required.} } \value{ Updated RO-Crate object with Safe Project information. diff --git a/man/safe_setting.Rd b/man/safe_setting.Rd index 478d227..c9d5945 100644 --- a/man/safe_setting.Rd +++ b/man/safe_setting.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/safe_setting.R \name{safe_setting} \alias{safe_setting} +\alias{safe_setting.ArmadilloCredentials} \alias{safe_setting.character} \alias{safe_setting.cr8tor} \alias{safe_setting.opal} @@ -16,6 +17,8 @@ \usage{ safe_setting(x, ...) +\method{safe_setting}{ArmadilloCredentials}(x, ...) + \method{safe_setting}{character}( x, ..., @@ -56,7 +59,7 @@ safe_setting(x, ...) } \arguments{ \item{x}{This can be a connection to a 'DataSHIELD' server (e.g., object with -the \code{opal} class, see \code{\link[opalr:opal.login]{opalr::opal.login()}}), an RO-Crate +the \code{opal} or \code{ArmadilloCredentials} classes), an RO-Crate (\link[rocrateR:rocrate]{rocrate} class) or a string with the path to an RO-Crate.} diff --git a/tests/testthat/helper-mock-opal.R b/tests/testthat/helper-mock-opal.R new file mode 100644 index 0000000..4042af1 --- /dev/null +++ b/tests/testthat/helper-mock-opal.R @@ -0,0 +1,14 @@ +#' Build a minimal fake `opal`-classed object for offline/mocked tests +#' +#' Carries just enough shape (a `username` field and the `"opal"` class) for +#' S3 dispatch to resolve to the `.opal` methods. It is never passed to a +#' real network call in these tests: every function that would otherwise +#' talk to a server (`backend_*()`, `validate_backend()`, etc.) is replaced +#' first via `testthat::local_mocked_bindings()`, so no live connection - and +#' therefore no `skip_on_cran()`/`skip_if_offline()` - is required. +fake_opal_con <- function(username = "test_user") { + structure( + list(username = username), + class = "opal" + ) +} diff --git a/tests/testthat/test-audit.R b/tests/testthat/test-audit.R new file mode 100644 index 0000000..e242d58 --- /dev/null +++ b/tests/testthat/test-audit.R @@ -0,0 +1,97 @@ +test_that("audit.default errors for unsupported classes", { + expect_error( + audit(structure(list(), class = "not_a_backend")), + "No `audit\\(\\)` method exists" + ) +}) + +test_that("audit.ArmadilloCredentials errors as not implemented", { + expect_error( + audit(structure(list(), class = "ArmadilloCredentials")), + "not currently implemented" + ) +}) + +test_that("audit.rocrate returns the input unchanged", { + roc <- structure(list(marker = "unchanged"), class = "rocrate") + + expect_identical(audit(roc), roc) +}) + +test_that("audit.list dispatches over every element", { + roc1 <- structure(list(marker = "one"), class = "rocrate") + roc2 <- structure(list(marker = "two"), class = "rocrate") + + result <- audit(list(roc1, roc2)) + + expect_identical(result, list(roc1, roc2)) +}) + +test_that("audit.character errors for a non-existent file", { + expect_error( + audit(file.path(tempdir(), "does-not-exist.yaml")), + "does not exist" + ) +}) + +test_that("audit.character surfaces both loader errors for an invalid file", { + tmp <- withr::local_tempfile(fileext = ".yaml") + writeLines("not: a valid cr8tor bundle or rocrate", tmp) + + err <- tryCatch(audit(tmp), error = function(e) e) + + expect_s3_class(err, "error") + expect_match(conditionMessage(err), "cr8tor bundle error:") + expect_match(conditionMessage(err), "rocrate error:") +}) + +test_that("audit.character dispatches a successfully loaded cr8tor bundle", { + stub_bundle <- structure(list(marker = "cr8tor-stub"), class = "cr8tor") + + local_mocked_bindings( + load_cr8tor_bundle = function(x, ...) stub_bundle, + `audit_engine.cr8tor` = function(x, ...) "AUDITED" + ) + + tmp <- withr::local_tempfile() + file.create(tmp) + + expect_equal(audit(tmp), "AUDITED") +}) + +test_that("audit.opal passes project/user/log args through to audit_engine", { + captured <- new.env() + + local_mocked_bindings( + `audit_engine.opal` = function( + x, + ..., + project = NULL, + user = NULL, + logs_from = -Inf, + logs_to = Inf, + path = NULL + ) { + captured$project <- project + captured$user <- user + captured$logs_from <- logs_from + captured$logs_to <- logs_to + "AUDITED" + } + ) + + con <- fake_opal_con() + result <- audit( + con, + project = "PROJECT1", + user = "alice", + logs_from = 100, + logs_to = 200 + ) + + expect_equal(result, "AUDITED") + expect_equal(captured$project, "PROJECT1") + expect_equal(captured$user, "alice") + expect_equal(captured$logs_from, 100) + expect_equal(captured$logs_to, 200) +}) diff --git a/tests/testthat/test-audit_engine.R b/tests/testthat/test-audit_engine.R new file mode 100644 index 0000000..4eb40de --- /dev/null +++ b/tests/testthat/test-audit_engine.R @@ -0,0 +1,205 @@ +test_that("audit_engine.default errors for unsupported classes", { + expect_error( + audit_engine(structure(list(), class = "not_a_backend")), + "No `audit_engine\\(\\)` method exists" + ) +}) + +test_that("audit_engine.opal requires a `project` argument", { + local_mocked_bindings(validate_backend = function(x, ...) invisible(TRUE)) + + con <- fake_opal_con() + + expect_error(audit_engine(con), "A `project` name is required") +}) + +test_that("audit_engine.opal errors for a project not on the server", { + local_mocked_bindings( + validate_backend = function(x, ...) invisible(TRUE), + backend_projects = function(x, ...) tibble::tibble(name = "REAL_PROJECT") + ) + + con <- fake_opal_con() + + expect_error( + audit_engine(con, project = "MISSING_PROJECT"), + "not valid" + ) +}) + +test_that("audit_engine.opal orchestrates the 5 Safes steps correctly", { + # two users on the server: `alice` (regular user) and `bob_admin` (has + # administrate permission, so should be excluded from Safe People/Output) + local_mocked_bindings( + validate_backend = function(x, ...) invisible(TRUE), + backend_projects = function(x, ...) tibble::tibble(name = "PROJECT1"), + backend_users = function(x, ..., df = FALSE) { + list( + list(principal = "alice", groups = list("auditor")), + list(principal = "bob_admin", groups = list("admin")) + ) + }, + backend_sys_perms = function(x, ...) { + tibble::tibble( + subject = c("alice", "bob_admin", "opal-administrator"), + permission = c("view", "administrate", "administrate"), + type = c("user", "user", "groups") + ) + } + ) + + # records what each Safe * step was called with, without needing `<<-`: + # environments are mutable by reference, so a plain `<-` inside the mock + # closures is enough to record calls in the enclosing test's scope + calls <- new.env() + calls$safe_people <- character() + calls$safe_project <- character() + calls$safe_data <- character() + calls$safe_output <- character() + calls$safe_setting <- FALSE + + local_mocked_bindings( + `safe_people.rocrate` = function( + x, + ..., + connection, + user, + set_author = TRUE, + set_project = TRUE + ) { + calls$safe_people <- c(calls$safe_people, user) + x + }, + `safe_project.rocrate` = function(x, ..., connection, project) { + calls$safe_project <- c(calls$safe_project, project) + x + }, + `safe_data.rocrate` = function(x, ..., connection, project) { + calls$safe_data <- c(calls$safe_data, project) + x + }, + `safe_output.rocrate` = function( + x, + ..., + connection, + user, + logs_from, + logs_to, + path = NULL + ) { + calls$safe_output <- c(calls$safe_output, user) + x + }, + `safe_setting.opal` = function(x, ..., rocrate) { + calls$safe_setting <- TRUE + rocrate + } + ) + + con <- fake_opal_con() + result <- audit_engine(con, project = "PROJECT1") + + # `bob_admin` is excluded because of the "administrate" permission + expect_equal(calls$safe_people, "alice") + expect_equal(calls$safe_output, "alice") + expect_equal(calls$safe_project, "PROJECT1") + expect_equal(calls$safe_data, "PROJECT1") + expect_true(calls$safe_setting) + expect_s3_class(result, "rocrate") +}) + +test_that("audit_engine.opal filters Safe People by the `user` argument", { + local_mocked_bindings( + validate_backend = function(x, ...) invisible(TRUE), + backend_projects = function(x, ...) tibble::tibble(name = "PROJECT1"), + backend_users = function(x, ..., df = FALSE) { + list( + list(principal = "alice", groups = list("standard")), + list(principal = "carol", groups = list("standard")) + ) + }, + backend_sys_perms = function(x, ...) { + tibble::tibble( + subject = c("alice", "carol", "opal-administrator"), + permission = c("view", "view", "administrate"), + type = c("user", "user", "groups") + ) + } + ) + + calls <- new.env() + calls$safe_people <- character() + + local_mocked_bindings( + `safe_people.rocrate` = function( + x, + ..., + connection, + user, + set_author = TRUE, + set_project = TRUE + ) { + calls$safe_people <- c(calls$safe_people, user) + x + }, + `safe_project.rocrate` = function(x, ...) x, + `safe_data.rocrate` = function(x, ...) x, + `safe_output.rocrate` = function(x, ...) x, + `safe_setting.opal` = function(x, ..., rocrate) rocrate + ) + + con <- fake_opal_con() + audit_engine(con, project = "PROJECT1", user = "alice") + + expect_equal(calls$safe_people, "alice") +}) + +test_that("audit_engine.opal errors if the `user` filter matches nobody", { + local_mocked_bindings( + validate_backend = function(x, ...) invisible(TRUE), + backend_projects = function(x, ...) tibble::tibble(name = "PROJECT1"), + backend_users = function(x, ..., df = FALSE) { + list( + list(principal = "alice", groups = list("standard")), + list(principal = "carol", groups = list("standard")) + ) + }, + backend_sys_perms = function(x, ...) { + tibble::tibble( + subject = c("alice", "carol", "opal-administrator"), + permission = c("view", "view", "administrate"), + type = c("user", "user", "groups") + ) + } + ) + + con <- fake_opal_con() + + expect_error( + audit_engine(con, project = "PROJECT1", user = "nobody_here"), + "No Safe People details were found" + ) +}) + +test_that("audit_engine.opal aborts if Safe People details cannot be obtained", { + # simulates e.g. a permissions-lookup failure on the server: + # `filter_safe_people()` falls back to an empty table internally, and + # since an audit is not meaningful without Safe People details, + # `audit_engine.opal()` should abort rather than silently producing an + # incomplete audit + local_mocked_bindings( + validate_backend = function(x, ...) invisible(TRUE), + backend_projects = function(x, ...) tibble::tibble(name = "PROJECT1"), + backend_users = function(x, ..., df = FALSE) { + list(list(principal = "alice", groups = list(character(0)))) + }, + backend_sys_perms = function(x, ...) stop("500 Internal Server Error") + ) + + con <- fake_opal_con() + + expect_error( + audit_engine(con, project = "PROJECT1"), + "No Safe People details could be found" + ) +}) diff --git a/tests/testthat/test-check_permissions.R b/tests/testthat/test-check_permissions.R new file mode 100644 index 0000000..7234a9e --- /dev/null +++ b/tests/testthat/test-check_permissions.R @@ -0,0 +1,70 @@ +test_that("check_permissions.default errors for unsupported classes", { + expect_error( + check_permissions(structure(list(), class = "not_a_backend")), + "No `check_permissions\\(\\)` method exists" + ) +}) + +test_that("check_permissions.ArmadilloCredentials errors as not implemented", { + expect_error( + check_permissions(structure(list(), class = "ArmadilloCredentials")), + "not currently implemented" + ) +}) + +test_that("check_permissions.opal succeeds for an admin connection", { + local_mocked_bindings( + backend_user_exists = function(x, ...) TRUE, + backend_profile_exists = function(x, ...) TRUE + ) + + con <- fake_opal_con() + + expect_true(isTRUE(check_permissions(con))) +}) + +test_that("check_permissions.opal succeeds for an auditor-only connection", { + # a pure auditor lacks admin access, so `backend_user_exists()` should + # error (403-like), while `backend_profile_exists()` still succeeds + local_mocked_bindings( + backend_user_exists = function(x, ...) stop("403 Forbidden"), + backend_profile_exists = function(x, ...) TRUE + ) + + con <- fake_opal_con() + + expect_true(isTRUE(check_permissions(con))) +}) + +test_that("check_permissions.opal errors when neither role is available", { + local_mocked_bindings( + backend_user_exists = function(x, ...) stop("403 Forbidden"), + backend_profile_exists = function(x, ...) stop("404 Not Found") + ) + + con <- fake_opal_con() + + expect_error(check_permissions(con), "does not have sufficient permissions") +}) + +test_that("check_permissions.opal is silent by default on success", { + local_mocked_bindings( + backend_user_exists = function(x, ...) TRUE, + backend_profile_exists = function(x, ...) TRUE + ) + + con <- fake_opal_con() + + expect_silent(check_permissions(con)) +}) + +test_that("check_permissions.opal shows a message when verbose = TRUE", { + local_mocked_bindings( + backend_user_exists = function(x, ...) TRUE, + backend_profile_exists = function(x, ...) TRUE + ) + + con <- fake_opal_con() + + expect_message(check_permissions(con, verbose = TRUE), "ready to audit") +}) diff --git a/tests/testthat/test-dsROCrate-package.R b/tests/testthat/test-dsROCrate-package.R index 03e64d9..e8f6f34 100644 --- a/tests/testthat/test-dsROCrate-package.R +++ b/tests/testthat/test-dsROCrate-package.R @@ -1,6 +1,6 @@ test_that("All Rd files have a value section", { - db <- tools::Rd_db("dsROCrate") - + man_dir <- testthat::test_path("..", "man") + db <- list.files(man_dir, pattern = "\\.Rd$", full.names = TRUE) # drop the package-level Rd (e.g., "dsROCrate-package") db <- db[!grepl("-package\\.Rd$", names(db))] diff --git a/tests/testthat/test-report.R b/tests/testthat/test-report.R index 551277f..a2086a8 100644 --- a/tests/testthat/test-report.R +++ b/tests/testthat/test-report.R @@ -398,6 +398,12 @@ test_that("report.list aggregates outputs from a study audit", { }) test_that("report.list handles missing outputs from a study audit", { + # create temporary file + tmp_dir <- file.path(tempdir(), "dsROCRate_tests") + dir.create(tmp_dir, recursive = TRUE) + on.exit(unlink(tmp_dir, recursive = TRUE, force = TRUE)) + out_file <- file.path(tmp_dir, "report.md") + testthat::with_mocked_bindings( report = function(...) list(), code = { @@ -405,7 +411,7 @@ test_that("report.list handles missing outputs from a study audit", { list(server1 = rocrateR::rocrate_5s()), study_name = "StudyX", render = FALSE, - filepath = tempfile(fileext = ".md") + filepath = out_file ) expect_type(result, "list") diff --git a/tests/testthat/test-utils-opal.R b/tests/testthat/test-utils-opal.R index 678ad46..ab1a03d 100644 --- a/tests/testthat/test-utils-opal.R +++ b/tests/testthat/test-utils-opal.R @@ -8,11 +8,11 @@ test_that("validate_con works with real Opal connection", { opalr::opal.logout(opal_con) }) -test_that("is_opal_admin_con detects admin connection correctly", { +test_that("is_admin_con detects admin connection correctly", { # open connection to OBiBa's Opal demo server opal_con <- opal_demo_con() - res <- is_opal_admin_con(opal_con) + res <- is_admin_con(opal_con) expect_type(res, "logical") expect_true(res) diff --git a/tests/testthat/test-utils-safe_people.R b/tests/testthat/test-utils-safe_people.R index 9a304b2..eb28f6e 100644 --- a/tests/testthat/test-utils-safe_people.R +++ b/tests/testthat/test-utils-safe_people.R @@ -39,20 +39,58 @@ test_that("extract_safe_people.opal updates an existing RO-Crate", { }) test_that("extract_safe_people.opal excludes admin and administrator accounts", { - # open connection to OBiBa's Opal demo server - opal_con <- opal_demo_con() - # terminate connection when done with tests - withr::defer(opalr::opal.logout(opal_con)) + # the real OBiBa demo server doesn't set the `administrate` permission on + # its `administrator` account, so this can't be exercised against it - + # simulate a server where the exclusion actually has something to catch + local_mocked_bindings( + backend_users = function(x, ..., df = FALSE) { + list( + list(principal = "alice", groups = list("auditor")), + list(principal = "bob_admin", groups = list("admin")) + ) + }, + backend_sys_perms = function(x, ...) { + tibble::tibble( + subject = c("alice", "bob_admin"), + permission = c("view", "administrate"), + type = c("user", "user") + ) + } + ) - roc <- extract_safe_people(opal_con) + # records which users actually got passed into `safe_people()`, without + # needing `<<-` - environments are mutable by reference + calls <- new.env() + calls$safe_people <- character() + + local_mocked_bindings( + `safe_people.rocrate` = function( + x, + ..., + connection, + user, + set_author = TRUE, + set_project = TRUE + ) { + calls$safe_people <- c( + calls$safe_people, + as.character(unlist(user, use.names = FALSE)) + ) + x + } + ) - people <- rocrateR::get_entity(roc, type = "Person") - ids <- vapply(people, function(e) getElement(e, "name")[[1]], character(1)) + con <- fake_opal_con() + roc <- extract_safe_people(con) - expect_false(any(tolower(ids) %in% c("admin", "administrator"))) + print(calls$safe_people) - # close connection to OBiBa's Opal demo server - opalr::opal.logout(opal_con) + # `administrator` never reaches `safe_people()` because it's excluded + # upstream, in `filter_safe_people()`, before the Person entity would + # ever be created + expect_false(any(tolower(calls$safe_people) %in% c("admin", "administrator"))) + expect_equal(calls$safe_people, "alice") + expect_s3_class(roc, "rocrate") }) test_that("extract_safe_people.opal iterates over all returned subject profiles", { @@ -61,7 +99,7 @@ test_that("extract_safe_people.opal iterates over all returned subject profiles" # terminate connection when done with tests withr::defer(opalr::opal.logout(opal_con)) - users_raw <- opalr::oadmin.user_profiles(opal_con, df = FALSE) + users_raw <- backend_users(opal_con, df = FALSE) users_tbl <- dplyr::bind_rows(users_raw) expect_true(nrow(users_tbl) >= 1) diff --git a/vignettes/audit-permissions.Rmd b/vignettes/audit-permissions.Rmd index fadbe87..6449516 100644 --- a/vignettes/audit-permissions.Rmd +++ b/vignettes/audit-permissions.Rmd @@ -124,10 +124,3 @@ Ensure the connected user has the permissions required for the target backend. See the backend-specific sections in this vignette for details. - -## Testing Opal permissions directly - -```{r eval = FALSE} -dsROCrate::is_opal_admin_con(con) -dsROCrate::is_opal_audit_con(con) -```