diff --git a/Dockerfile b/Dockerfile index e444fe18..d025a7bd 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,4 @@ -FROM ghcr.io/afwillia/shiny-base:release-1.9 +FROM ghcr.io/afwillia/shiny-base:release-1.12 # add version tag as a build argument ARG DCA_VERSION diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R index d2a574fb..6c108cd2 100644 --- a/R/schematic_rest_api.R +++ b/R/schematic_rest_api.R @@ -134,7 +134,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", access_token, asset_view = NULL, json_str = NULL, - data_model_labels = "class_label") { + data_model_labels = "class_label", + dataset_scope = NULL) { flattenbody <- function(x) { # A form/query can only have one value per name, so take @@ -175,7 +176,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", restrict_rules=restrict_rules, project_scope = project_scope, data_model_labels = data_model_labels, - asset_view = asset_view + asset_view = asset_view, + dataset_scope = dataset_scope ) |> httr2::req_body_multipart(file_name=curl::form_file(file_name)) |> httr2::req_perform() @@ -191,7 +193,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", project_scope = project_scope, asset_view = asset_view, data_model_labels = data_model_labels, - json_str = json_str + json_str = json_str, + dataset_scope = dataset_scope ) |> #httr2::req_retry( # max_tries = 3, @@ -216,7 +219,14 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", # ) # ) # } - httr2::resp_body_json(resp) + if (httr2::resp_is_error(resp)) { + list(list( + "errors" = list( + Row = NA, Column = NA, Value = NA, + Error = httr2::resp_body_string(resp) + ) + )) + } else httr2::resp_body_json(resp) } diff --git a/R/synapse_rest_api.R b/R/synapse_rest_api.R index 94cac87f..191fb8da 100644 --- a/R/synapse_rest_api.R +++ b/R/synapse_rest_api.R @@ -146,7 +146,7 @@ synapse_entity_children <- function(url = "https://repo-prod.prod.sagebase.org/r resp <- httr::content(req) output <- c(output, resp$page) } - bind_rows(output) + dplyr::bind_rows(output) } @@ -157,6 +157,9 @@ synapse_entity_children <- function(url = "https://repo-prod.prod.sagebase.org/r #' @param nextPageToken Synapse next page token synapse_projects_user <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/projects/user", auth, nextPageToken=NULL) { principalId <- synapse_user_profile(auth = auth)[["ownerId"]] + + if (is.null(principalId)) stop("Synapse token not valid") + hreq <- httr::GET(url = file.path(url, principalId), query = list(nextPageToken=nextPageToken)) output <- list() @@ -174,7 +177,7 @@ synapse_projects_user <- function(url = "https://repo-prod.prod.sagebase.org/rep #' @title Get projects within scope of Synapse project #' #' @param url Synapse api endpoint -#' @param id Synapse ID +#' @param id Synapse project ID #' @param auth Synapse token synapse_get_project_scope <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity/", id, auth) { diff --git a/R/utils.R b/R/utils.R index 4ea8a93e..2975253e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -11,4 +11,18 @@ parse_env_var <- function(x, el_delim=",", kv_delim=":"){ kv <- stringr::str_split(y, kv_delim, n=2) setNames(kv[[1]][[2]], kv[[1]][[1]]) })) +} + +#' @title Truncate the results of schematic validation +#' @param x Schematic validation result +#' @param n Number of records to keep +#' @export +format_validation_response <- function(x, n = 50) { + if ("errors" %in% names(x) && length(x$errors) > n) { + x$errors <- x$errors[1:n] + } + if ("warnings" %in% names(x) && length(x$warnings) > n) { + x$warnings <- x$warnings[1:n] + } + x } \ No newline at end of file diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R index 1e1546c2..6c108cd2 100644 --- a/functions/schematic_rest_api.R +++ b/functions/schematic_rest_api.R @@ -6,6 +6,11 @@ check_success <- function(x){ if (tolower(status$category) == "success") { return() } else { + # Return content text for Data Type errors + if (grepl("LookupError: The DataType", httr::content(x, "text"))) { + stop(httr::content(x, "text")) + } + stop(sprintf("Response from server: %s", status$reason)) } } @@ -129,7 +134,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", access_token, asset_view = NULL, json_str = NULL, - data_model_labels = "class_label") { + data_model_labels = "class_label", + dataset_scope = NULL) { flattenbody <- function(x) { # A form/query can only have one value per name, so take @@ -170,7 +176,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", restrict_rules=restrict_rules, project_scope = project_scope, data_model_labels = data_model_labels, - asset_view = asset_view + asset_view = asset_view, + dataset_scope = dataset_scope ) |> httr2::req_body_multipart(file_name=curl::form_file(file_name)) |> httr2::req_perform() @@ -186,7 +193,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", project_scope = project_scope, asset_view = asset_view, data_model_labels = data_model_labels, - json_str = json_str + json_str = json_str, + dataset_scope = dataset_scope ) |> #httr2::req_retry( # max_tries = 3, @@ -211,7 +219,14 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", # ) # ) # } - httr2::resp_body_json(resp) + if (httr2::resp_is_error(resp)) { + list(list( + "errors" = list( + Row = NA, Column = NA, Value = NA, + Error = httr2::resp_body_string(resp) + ) + )) + } else httr2::resp_body_json(resp) } @@ -221,8 +236,18 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", #' @param schema_url URL to a schema jsonld #' @param data_type Type of dataset #' @param dataset_id Synapse ID of existing manifest -#' @param access_token Synapse login cookie, PAT, or API key. -#' @param csv_file Filepath of csv to validate +#' @param restrict_rules Default = FALSE +#' @param access_token Synapse login cookie, PAT, or API key +#' @param json_str Json string to submit +#' @param asset_view Synapse fileview +#' @param manifest_record_type Default = "table_and_file" +#' @param file_name Name of file +#' @param table_manipulation Default = "replace" +#' @param hide_blanks Default = FALSE +#' @param table_column_names Default = "class_and_label" +#' @param annotation_keys Default = "class_and_label" +#' @param data_model_labels Default = "class_and_label" +#' @param upload_file_annotations Default = TRUE #' #' @returns TRUE if successful upload or validate errors if not. #' @export @@ -240,7 +265,8 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", hide_blanks=FALSE, table_column_names="class_label", annotation_keys="class_label", - data_model_labels="class_label") { + data_model_labels="class_label", + file_annotations_upload=TRUE) { req <- httr::POST(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( @@ -255,7 +281,8 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", table_column_names=table_column_names, annotation_keys=annotation_keys, data_model_labels=data_model_labels, - hide_blanks=hide_blanks), + hide_blanks=hide_blanks, + file_annotations_upload=file_annotations_upload), body=list(file_name=httr::upload_file(file_name)) #body=list(file_name=file_name) ) @@ -397,7 +424,7 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta check_success(req) if (return_type=="json") { - return(list2DF(fromJSON(httr::content(req)))) + return(list2DF(jsonlite::fromJSON(httr::content(req)))) } else { csv <- readr::read_csv(httr::content(req), show_col_types = FALSE) return(csv) diff --git a/global.R b/global.R index 2e17e23d..62fa4e01 100644 --- a/global.R +++ b/global.R @@ -106,22 +106,7 @@ app <- oauth_app("shinysynapse", # These are the user info details ('claims') requested from Synapse: claims <- list( - family_name = NULL, - given_name = NULL, - email = NULL, - email_verified = NULL, - userid = NULL, - orcid = NULL, - is_certified = NULL, - is_validated = NULL, - validated_given_name = NULL, - validated_family_name = NULL, - validated_location = NULL, - validated_email = NULL, - validated_company = NULL, - validated_at = NULL, - validated_orcid = NULL, - company = NULL + userid = NULL ) claimsParam <- toJSON(list(id_token = claims, userinfo = claims)) diff --git a/modules/DTable.R b/modules/DTable.R index 8632c398..5ecd595c 100644 --- a/modules/DTable.R +++ b/modules/DTable.R @@ -57,7 +57,7 @@ DTableServer <- function(id, data, escape = TRUE, df <- df %>% formatStyle(1:ncol(data), border = "1px solid #ddd") } - output$table <- renderDT(df, future = TRUE) + output$table <- renderDT(df, future = TRUE, server = TRUE) } ) } diff --git a/server.R b/server.R index f9e418ab..f624d983 100644 --- a/server.R +++ b/server.R @@ -279,6 +279,7 @@ shinyServer(function(input, output, session) { try( { scopes <- synapse_get_project_scope(id = .asset_view, auth = access_token) + scopes <- unique(scopes) scope_access <- vapply(scopes, function(x) { synapse_access(id = x, access = "DOWNLOAD", auth = access_token) }, 1L) @@ -805,14 +806,16 @@ shinyServer(function(input, output, session) { .dd_template <- input$dropdown_template .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules .project_scope <- NULL + .dataset_scope <- selected$folder() .access_token <- access_token .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels # asset view must be NULL to avoid cross-manifest validation. + # however, it is necessary for filename validation + # always pass asset view, let the data model decide which validations are run # doing this in a verbose way to avoid warning with ifelse - .asset_view <- NULL + .asset_view <- selected$master_asset_view() if (!is.null(dcc_config_react()$schematic$model_validate$enable_cross_manifest_validation) & isTRUE(dcc_config_react()$schematic$model_validate$enable_cross_manifest_validation)) { - .asset_view <- selected$master_asset_view() .project_scope <- selected$project() } @@ -833,7 +836,8 @@ shinyServer(function(input, output, session) { project_scope = .project_scope, access_token = .access_token, data_model_labels = .data_model_labels, - asset_view = .asset_view + asset_view = .asset_view, + dataset_scope = .dataset_scope ), { list(list( @@ -846,6 +850,7 @@ shinyServer(function(input, output, session) { ) # validation messages + annotation_status <- format_validation_response(annotation_status, 50) validationResult(annotation_status, .dd_template, .infile_data) }) %...>% validation_res() }) @@ -1067,7 +1072,7 @@ shinyServer(function(input, output, session) { .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules .hide_blanks <- dcc_config_react()$schematic$model_submit$hide_blanks .file_annotations_upload <- dcc_config_react()$schematic$model_submit$file_annotations_upload - + # associates metadata with data and returns manifest id promises::future_promise({ try( diff --git a/shiny-server.conf b/shiny-server.conf index 6fd89378..a950f6fa 100644 --- a/shiny-server.conf +++ b/shiny-server.conf @@ -25,6 +25,9 @@ server { # When a user visits the base URL rather than a particular application, # an index of the applications available in this directory will NOT be shown. directory_index off; + + # Don't automatically reap user's session upon disconnect + reconnect false; } } diff --git a/tests/testthat/test_synapse_rest_api.R b/tests/testthat/test_synapse_rest_api.R index 7165fd20..050b78f2 100644 --- a/tests/testthat/test_synapse_rest_api.R +++ b/tests/testthat/test_synapse_rest_api.R @@ -24,13 +24,152 @@ test_that("is_certified returns TRUE or FALSE", { }) -test_that("get returns a tibble or error", { +test_that("synapse_get returns a tibble", { - good_req <- synapse_get(id="syn23643255", auth=Sys.getenv("SYNAPSE_PAT")) + good_req <- synapse_get(id="syn61941085", auth=Sys.getenv("SYNAPSE_PAT")) expect_true(length(good_req) > 1) +}) + +test_that("synapse_get errors as expected", { + # nonexistant id expect_error(synapse_get(id="bad", auth=Sys.getenv("SYNAPSE_PAT"))) + + # NULL id expect_error(synapse_get(id=NULL, auth=Sys.getenv("SYNAPSE_PAT"))) + + # nonexistant id and auth expect_error(synapse_get(id="bad", auth="bad")) }) + +test_that("synapse_access returns TRUE/FALSE", { + + # has DOWNLOAD access + expect_true( + synapse_access(id="syn62147982", access = "DOWNLOAD", auth=Sys.getenv("SYNAPSE_PAT")) + ) + + # doesn not have DOWNLOAD access + expect_false( + synapse_access(id="syn23643255", access = "DOWNLOAD", auth=Sys.getenv("SYNAPSE_PAT")) + ) + + # Bad PAT ("") + expect_false( + synapse_access(id="syn23643255", access = "DOWNLOAD", auth="") + ) +}) + +test_that("synapse_access returns errors as expected", { + + # non existent access argument + expect_error( + synapse_access(id="syn23643255", access = "TYPO", auth=Sys.getenv("SYNAPSE_PAT")) + ) + + # non existent id argument + expect_error( + synapse_access(id="not an id", access = "DOWNLOAD", auth=Sys.getenv("SYNAPSE_PAT")) + ) + + # bad PAT (string) + expect_error( + synapse_access(id="syn23643255", access = "DOWNLOAD", auth="adfadsf") + ) +}) + +test_that("synapse_entity_children returns a tibble", { + + # all arguments valid + req <- synapse_entity_children( + parentId="syn35187716", includeTypes = list("file", "folder"), auth=Sys.getenv("SYNAPSE_PAT") + ) + + expect_true( + all(c("tbl_df", "data.frame") %in% class(req)) + ) + + # no children to return + req_no_children <- synapse_entity_children( + parentId="syn35187716", includeTypes = "projects", auth=Sys.getenv("SYNAPSE_PAT") + ) + + expect_true( + all(c("tbl_df", "data.frame") %in% class(req_no_children)) + ) + + # typo in parentId + req_parentId_typo <- synapse_entity_children( + parentId="not an id", includeTypes = "projects", auth=Sys.getenv("SYNAPSE_PAT") + ) + + expect_true( + all(c("tbl_df", "data.frame") %in% class(req_parentId_typo)) + ) + + # typo in auth + req_auth_typo <- synapse_entity_children( + parentId="syn35187716", includeTypes = "projects", auth="not an auth" + ) + + expect_true( + all(c("tbl_df", "data.frame") %in% class(req_auth_typo)) + ) +}) + +test_that("synapse_projects_user returns expected tibble", { + req <- synapse_projects_user(auth=Sys.getenv("SYNAPSE_PAT")) + expect_identical(names(req), c("name", "id", "lastActivity", "modifiedOn", "modifiedBy")) +}) + +test_that("synapse_projects_user errors when auth token is not valid", { + expect_error( + req <- synapse_projects_user(auth="ABC") + ) +}) + +test_that("synapse_table_query", { + + # Return token + id <- "syn61941085" + query <- sprintf("select id from %s limit 1", id) + token <- synapse_table_query(id = id, auth = Sys.getenv("SYNAPSE_PAT"), query = query, partMask = 0x10) + + expect_identical(names(token), "token") + + # not a table (returns error message but does not error) + id <- "syn52578158" + query <- sprintf("select id from %s limit 1", id) + project_resp <- synapse_table_query(id = id, query = query, partMask = 0x10, auth = Sys.getenv("SYNAPSE_PAT")) + + expect_identical(project_resp$reason, "syn52578158 is not a table or view") + + # invalid access token (returns error message but does not error) + id <- "syn52578158" + query <- sprintf("select id from %s limit 1", id) + invalid_auth_resp <- synapse_table_query(id = id, query = query, partMask = 0x10, auth = "auth") + + expect_identical(invalid_auth_resp$reason, "Invalid access token") +}) + +# TODO: Add tests for functions used in DCA dashboard modules +# test_that("synapse_table_get success", { +# +# }) +# +# test_that("get_synapse_table_names success", { +# +# }) + +# test_that("synapse_storage_projects success", { +# +# }) +# +# test_that("synapse_download_file_handle success", { +# +# }) +# +# test_that("synapse_get_manifests_in_asset_view success", { +# +# })