diff --git a/DESCRIPTION b/DESCRIPTION index 58d0f818f..9e8e5936e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: riskassessment Title: A web app designed to interface with the `riskmetric` package -Version: 3.0.0.9009 +Version: 3.0.0.9010 Authors@R: c( person("Aaron", "Clark", role = c("aut", "cre"), email = "aaron.clark@biogen.com"), person("Robert", "Krajcik", role = "aut", email = "robert.krajcik@biogen.com"), diff --git a/NEWS.md b/NEWS.md index 82a4734b6..33beb9873 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,6 +9,7 @@ * Fixed bug where HTML reports displayed a darker green in the cards' meters * Only run configuration checkers when configuring the database * Added dependencies/reverse dependencies card hyperlink (#597) +* Added non-shinymanager deployment option (#700) # riskassessment 3.0.0 diff --git a/R/app_server.R b/R/app_server.R index d0a1ae35e..30eb53690 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -41,6 +41,11 @@ app_server <- function(input, output, session) { res_auth[["admin"]] <- !isTRUE(golem::get_golem_options('nonadmin')) res_auth[["user"]] <- "test_user" res_auth[["role"]] <- ifelse(!isTRUE(golem::get_golem_options('nonadmin')), "admin", "reviewer") + } else if (isFALSE(get_db_config("use_shinymanager"))) { + res_auth <- reactiveValues() + res_auth[["admin"]] <- FALSE + res_auth[["user"]] <- session$user %||% "anonymous" + res_auth[["role"]] <- intersect(unlist(session$groups, use.names = FALSE), dbSelect("select user_role from roles")[[1]]) %||% "default" } else { # check_credentials directly on sqlite db res_auth <- shinymanager::secure_server( @@ -64,7 +69,7 @@ app_server <- function(input, output, session) { }) observeEvent(res_auth$user, { - req(res_auth$admin == TRUE | "weight_adjust" %in% credential_config$privileges[[res_auth$role]]) + req(res_auth$admin == TRUE || any(c("admin", "weight_adjust") %in% unlist(credential_config$privileges[res_auth$role]))) appendTab("apptabs", tabPanel( @@ -86,12 +91,13 @@ app_server <- function(input, output, session) { admin_ui } ), - if (res_auth$admin) + if (res_auth$admin == TRUE || "admin" %in% unlist(credential_config$privileges[res_auth$role])) tabPanel( id = "privilege_id", title = "Roles & Privileges", mod_user_roles_ui("userRoles") ), + if ("weight_adjust" %in% unlist(credential_config$privileges[res_auth$role])) tabPanel( id = "reweight_id", title = "Assessment Reweighting", @@ -105,7 +111,7 @@ app_server <- function(input, output, session) { observeEvent(credential_config$privileges, { req(user$role) - if ("weight_adjust" %in% credential_config$privileges[[user$role]]) + if ("weight_adjust" %in% unlist(credential_config$privileges[user$role])) showTab("credentials", "Assessment Reweighting") else hideTab("credentials", "Assessment Reweighting") diff --git a/R/mod_addComment.R b/R/mod_addComment.R index a92ba1d33..59b594595 100644 --- a/R/mod_addComment.R +++ b/R/mod_addComment.R @@ -32,7 +32,7 @@ addCommentUI <- function(id) { #' addCommentServer <- function(id, metric_abrv, user, credentials, pkg_name) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { @@ -50,14 +50,14 @@ addCommentServer <- function(id, metric_abrv, user, credentials, pkg_name) { width = "100%", rows = 4, placeholder = glue::glue( - "Commenting as user: {user$name}, role: {user$role}" + "Commenting as user: {user$name}, role: {paste(user$role, collapse = ', ')}" ) ) }) observeEvent(input$submit_comment, { req(input$add_comment) - req("general_comment" %in% credentials$privileges[[user$role]]) + req("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) comment <- trimws(input$add_comment) @@ -65,7 +65,7 @@ addCommentServer <- function(id, metric_abrv, user, credentials, pkg_name) { dbUpdate( "INSERT INTO comments values({pkg_name()}, {user$name}, - {user$role}, {comment}, {metric_abrv}, + {paste(user$role, collapse = ', ')}, {comment}, {metric_abrv}, {getTimeStamp()})" ) diff --git a/R/mod_code_explorer.R b/R/mod_code_explorer.R index 436a4ca4e..571cd005b 100644 --- a/R/mod_code_explorer.R +++ b/R/mod_code_explorer.R @@ -73,7 +73,7 @@ mod_code_explorer_server <- function(id, selected_pkg, pkgdir = reactiveVal(), c ), br(), br(), div(id = ns("comments_for_fe"), fluidRow( - if ("general_comment" %in% credentials$privileges[[user$role]]) addCommentUI(id = ns("add_comment")), + if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(id = ns("add_comment")), viewCommentsUI(id = ns("view_comments")))) ) } diff --git a/R/mod_communityMetrics.R b/R/mod_communityMetrics.R index 598d163b6..fb1973303 100644 --- a/R/mod_communityMetrics.R +++ b/R/mod_communityMetrics.R @@ -25,7 +25,7 @@ communityMetricsUI <- function(id) { #' communityMetricsServer <- function(id, selected_pkg, community_metrics, user, credentials) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { @@ -51,7 +51,7 @@ communityMetricsServer <- function(id, selected_pkg, community_metrics, user, cr plotly::plotlyOutput(NS(id, "downloads_plot"), height = "500px")))), br(), br(), div(id = "comments_for_cum", fluidRow( - if ("general_comment" %in% credentials$privileges[[user$role]]) addCommentUI(id = session$ns("add_comment")), + if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(id = session$ns("add_comment")), viewCommentsUI(id = session$ns("view_comments")))) ) } diff --git a/R/mod_decision_automation.R b/R/mod_decision_automation.R index 2bf6db1fe..a676e62d9 100644 --- a/R/mod_decision_automation.R +++ b/R/mod_decision_automation.R @@ -94,7 +94,7 @@ mod_decision_automation_ui_2 <- function(id){ #' @importFrom sortable sortable_js sortable_options sortable_js_capture_input mod_decision_automation_server <- function(id, user, credentials){ if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer( id, function(input, output, session){ ns <- session$ns @@ -428,7 +428,7 @@ mod_decision_automation_server <- function(id, user, credentials){ #### Outputs #### purrr::walk(c("auto_dropdown", "auto_dropdown2"), ~ observeEvent(input[[.x]], { - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) showModal(modalDialog( size = "l", @@ -515,7 +515,7 @@ mod_decision_automation_server <- function(id, user, credentials){ }) output$auto_classify <- renderUI({ - if ("auto_decision_adjust" %in% credentials$privileges[[user$role]]) { + if ("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) { tagList( br(),br(), hr(), @@ -540,7 +540,7 @@ mod_decision_automation_server <- function(id, user, credentials){ }) output$decision_rule_div <- renderUI({ - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) tagList( div( style = "display: flex", @@ -625,7 +625,7 @@ mod_decision_automation_server <- function(id, user, credentials){ output$auto_settings <- renderUI({ - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) div( style = "float: right;", @@ -637,7 +637,7 @@ mod_decision_automation_server <- function(id, user, credentials){ output$auto_settings2 <- renderUI({ - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) div( style = "float: right;", @@ -721,7 +721,7 @@ mod_decision_automation_server <- function(id, user, credentials){ }) observeEvent(input$submit_auto, { - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) showModal(modalDialog( size = "l", @@ -752,7 +752,7 @@ mod_decision_automation_server <- function(id, user, credentials){ }) observeEvent(input$submit_color, { - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) showModal(modalDialog( size = "l", @@ -784,7 +784,7 @@ mod_decision_automation_server <- function(id, user, credentials){ }) observeEvent(input$confirm_submit_auto, { - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) req(!disable_auto_submit()) out_lst <- purrr::compact(reactiveValuesToList(auto_decision)) @@ -796,7 +796,7 @@ mod_decision_automation_server <- function(id, user, credentials){ if (rlang::is_empty(rules_updates)) { risk_rule_update(rules_updates) dbUpdate("DELETE FROM rules") - loggit::loggit("INFO", glue::glue("Decision automation rules have been disabled by {user$name} ({user$role}).")) + loggit::loggit("INFO", glue::glue("Decision automation rules have been disabled by {user$name} ({paste(user$role, collapse = ', ')}).")) } else { if (!is.null(rule_lst[["rule_else"]][["decision"]])) rules_updates[["rule_else"]] <- rule_lst[["rule_else"]] @@ -812,7 +812,7 @@ mod_decision_automation_server <- function(id, user, credentials){ glue::glue_collapse(", ") dbUpdate("DELETE FROM rules") dbUpdate(glue::glue("INSERT INTO rules (rule_type, metric_id, condition, decision_id) VALUES {rule_out};")) - loggit::loggit("INFO", glue::glue("Decision automation rules were updated/implemented by {user$name} ({user$role}).")) + loggit::loggit("INFO", glue::glue("Decision automation rules were updated/implemented by {user$name} ({paste(user$role, collapse = ', ')}).")) } removeModal() @@ -829,7 +829,7 @@ mod_decision_automation_server <- function(id, user, credentials){ observeEvent(input$confirm_submit_col, { - req("auto_decision_adjust" %in% credentials$privileges[[user$role]]) + req("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) selected_colors <- decision_lst %>% @@ -839,7 +839,7 @@ mod_decision_automation_server <- function(id, user, credentials){ dbUpdate("UPDATE decision_categories SET color = {.x} WHERE decision = {.y}") shinyjs::runjs(glue::glue("document.documentElement.style.setProperty('--{risk_lbl(.y, type = 'attribute')}-color', '{.x}');")) }) - loggit::loggit("INFO", glue::glue("The decision category display colors were modified by {user$name} ({user$role})")) + loggit::loggit("INFO", glue::glue("The decision category display colors were modified by {user$name} ({paste(user$role, collapse = ', ')})")) color_current(selected_colors) removeModal() diff --git a/R/mod_downloadHandler.R b/R/mod_downloadHandler.R index b460619f4..d1a65a84c 100644 --- a/R/mod_downloadHandler.R +++ b/R/mod_downloadHandler.R @@ -269,7 +269,7 @@ mod_downloadHandler_server <- function(id, pkgs, user, metric_weights){ app_version = golem::get_golem_options('app_version'), metric_weights = metric_weights(), user_name = user$name, - user_role = user$role, + user_role = paste(user$role, collapse = ', '), overall_comments = overall_comments, pkg_summary = pkg_summary, mm_comments = mm_comments, diff --git a/R/mod_introJS.R b/R/mod_introJS.R index cffb13862..06637d662 100644 --- a/R/mod_introJS.R +++ b/R/mod_introJS.R @@ -33,11 +33,11 @@ introJSUI <- function(id) { #' @keywords internal introJSServer <- function(id, text, user, credentials) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { steps <- reactive({ - if(user$admin || "weight_adjust" %in% credentials$privileges[[user$role]]) { + if(user$admin || "weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) { apptab_steps <- bind_rows(apptab_admn, apptab_steps) } diff --git a/R/mod_maintenanceMetrics.R b/R/mod_maintenanceMetrics.R index 51e79267c..79cbd8900 100644 --- a/R/mod_maintenanceMetrics.R +++ b/R/mod_maintenanceMetrics.R @@ -20,7 +20,7 @@ maintenanceMetricsUI <- function(id) { #' maintenanceMetricsServer <- function(id, selected_pkg, maint_metrics, user, credentials, parent) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { ns <- NS(id) @@ -39,7 +39,7 @@ maintenanceMetricsServer <- function(id, selected_pkg, maint_metrics, user, cred metricGridUI(NS(id, 'metricGrid')), br(), br(), fluidRow(div(id = "comments_for_mm", - if ("general_comment" %in% credentials$privileges[[user$role]]) addCommentUI(NS(id, 'add_comment')), + if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(NS(id, 'add_comment')), viewCommentsUI(NS(id, 'view_comments'))) ) ) diff --git a/R/mod_pkg_explorer.R b/R/mod_pkg_explorer.R index e5b62ad21..050f7f73e 100644 --- a/R/mod_pkg_explorer.R +++ b/R/mod_pkg_explorer.R @@ -68,7 +68,7 @@ mod_pkg_explorer_server <- function(id, selected_pkg, ), br(), br(), div(id = ns("comments_for_se"), fluidRow( - if ("general_comment" %in% credentials$privileges[[user$role]]) addCommentUI(id = ns("add_comment")), + if ("general_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) addCommentUI(id = ns("add_comment")), viewCommentsUI(id = ns("view_comments")))), id = id ) diff --git a/R/mod_reportPreview.R b/R/mod_reportPreview.R index 26f01e7bc..04397a5ee 100644 --- a/R/mod_reportPreview.R +++ b/R/mod_reportPreview.R @@ -40,7 +40,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics, downloads_plot_data, user, credentials, app_version, metric_weights) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { @@ -82,7 +82,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics, br(), br(), - if ("overall_comment" %in% credentials$privileges[[user$role]]) + if ("overall_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) div(id = NS(id, "pkg-summary-grp"), # Compose pkg summary - either disabled, enabled, or pre-populated uiOutput(NS(id, "pkg_summary_ui")), @@ -119,7 +119,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics, HTML("R Package Risk Assessment
"), HTML(glue::glue("Report for Package: {selected_pkg$name()}
")), if("Report Author" %in% report_includes()) - HTML(glue::glue("Author (Role): {user$name} ({user$role})
")), + HTML(glue::glue("Author (Role): {user$name} ({paste(user$role, collapse = ', ')})
")), if("Report Date" %in% report_includes()) HTML(glue::glue("Report Date: {format(get_time(), '%B %d, %Y')}
")), @@ -289,7 +289,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics, } else { # first summary! dbUpdate( "INSERT INTO comments - VALUES ({selected_pkg$name()}, {user$name}, {user$role}, + VALUES ({selected_pkg$name()}, {user$name}, {paste(user$role, collapse = ', ')}, {current_summary}, 's', {getTimeStamp()})") showModal(modalDialog( title = h2("Summary Submitted"), @@ -315,7 +315,7 @@ reportPreviewServer <- function(id, selected_pkg, maint_metrics, com_metrics, SET comment = {input$pkg_summary}, added_on = {getTimeStamp()} WHERE id = {selected_pkg$name()} AND user_name = {user$name} AND - user_role = {user$role} AND + user_role = {paste(user$role, collapse = ', ')} AND comment_type = 's'" ) diff --git a/R/mod_reweightView.R b/R/mod_reweightView.R index c139e3ce3..4cba4e44b 100644 --- a/R/mod_reweightView.R +++ b/R/mod_reweightView.R @@ -26,7 +26,7 @@ reweightViewUI <- function(id) { #' @keywords internal reweightViewServer <- function(id, user, decision_list, credentials) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { exportTestValues( @@ -46,7 +46,7 @@ reweightViewServer <- function(id, user, decision_list, credentials) { ) observeEvent(input$update_weight, { - req("weight_adjust" %in% credentials$privileges[[user$role]]) + req("weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) curr_new_wts(save$data %>% dplyr::mutate(new_weight = ifelse(name == isolate(input$metric_name), isolate(input$metric_weight), new_weight))) @@ -184,7 +184,7 @@ reweightViewServer <- function(id, user, decision_list, credentials) { # Update metric weight dropdown so that it matches the metric name. observeEvent(input$metric_name, { - req("weight_adjust" %in% credentials$privileges[[user$role]]) + req("weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) shinyjs::disable("update_weight") updateNumericInput(session, "metric_weight", @@ -199,14 +199,14 @@ reweightViewServer <- function(id, user, decision_list, credentials) { # Note that another of the observeEvents will update the metric weight after # the selected metric name is updated. observeEvent(input$weights_table_rows_selected, { - req("weight_adjust" %in% credentials$privileges[[user$role]]) + req("weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) updateSelectInput(session, "metric_name", selected = curr_new_wts()$name[input$weights_table_rows_selected]) }) # Save new weight into db. observeEvent(input$update_pkg_risk, { - req("weight_adjust" %in% credentials$privileges[[user$role]]) + req("weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) # if you the user goes input$back2dash, then when they return to the if(n_wts_chngd() == 0){ @@ -243,7 +243,7 @@ reweightViewServer <- function(id, user, decision_list, credentials) { # Upon confirming the risk re-calculation observeEvent(input$confirm_update_risk, { - req("weight_adjust" %in% credentials$privileges[[user$role]]) + req("weight_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) removeModal() session$userData$trigger_events[["reset_pkg_upload"]] <- session$userData$trigger_events[["reset_pkg_upload"]] + 1 @@ -285,11 +285,11 @@ reweightViewServer <- function(id, user, decision_list, credentials) { # insert comment for both mm and cum tabs for (typ in c("mm","cum")) { dbUpdate( - 'INSERT INTO comments - VALUES({all_pkgs$pkg_name[i]}, {user$name}, {user$role}, + "INSERT INTO comments + VALUES({all_pkgs$pkg_name[i]}, {user$name}, {paste(user$role, collapse = ', ')}, {paste0(weight_risk_comment(all_pkgs$pkg_name[i]), - ifelse(all_pkgs$pkg_name[i] %in% cmt_or_dec_pkgs$pkg_name, cmt_or_dec_dropped_cmt, ""))}, - {typ}, {getTimeStamp()})' + ifelse(all_pkgs$pkg_name[i] %in% cmt_or_dec_pkgs$pkg_name, cmt_or_dec_dropped_cmt, ''))}, + {typ}, {getTimeStamp()})" ) } } diff --git a/R/mod_sidebar.R b/R/mod_sidebar.R index 212f04a59..1f4356eea 100644 --- a/R/mod_sidebar.R +++ b/R/mod_sidebar.R @@ -115,7 +115,7 @@ sidebarUI <- function(id) { #' sidebarServer <- function(id, user, uploaded_pkgs, credentials) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { # Required for shinyhelper to work. @@ -224,7 +224,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { # Update db if comment is submitted. observeEvent(input$submit_overall_comment, { - req("overall_comment" %in% credentials$privileges[[user$role]]) + req("overall_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) current_comment <- trimws(input$overall_comment) @@ -258,7 +258,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { } else { dbUpdate( "INSERT INTO comments - VALUES ({selected_pkg$name}, {user$name}, {user$role}, + VALUES ({selected_pkg$name}, {user$name}, {paste(user$role, collapse = ', ')}, {current_comment}, 'o', {getTimeStamp()})") updateTextAreaInput(session, "overall_comment", value = "", @@ -277,14 +277,14 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { observeEvent(input$submit_overall_comment_yes, { req(selected_pkg$name) - req("overall_comment" %in% credentials$privileges[[user$role]]) + req("overall_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) dbUpdate( "UPDATE comments SET comment = {input$overall_comment}, added_on = {getTimeStamp()} WHERE id = {selected_pkg$name} AND user_name = {user$name} AND - user_role = {user$role} AND + user_role = {paste(user$role, collapse = ', ')} AND comment_type = 'o'" ) current_comment <- trimws(input$overall_comment) @@ -334,7 +334,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { observeEvent(req(input$select_ver, session$userData$trigger_events$reset_sidebar), { if (input$select_pkg != "-" && input$select_ver != "-" && (rlang::is_empty(selected_pkg$decision) || is.na(selected_pkg$decision)) && - "overall_comment" %in% credentials$privileges[[user$role]]) { + "overall_comment" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) { shinyjs::enable("overall_comment") shinyjs::enable("submit_overall_comment") @@ -345,7 +345,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { }, ignoreInit = TRUE) observeEvent(req(input$select_ver, session$userData$trigger_events$reset_sidebar), { - req("final_decision" %in% credentials$privileges[[user$role]]) + req("final_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) if (input$select_pkg != "-" && input$select_ver != "-" && (rlang::is_empty(selected_pkg$decision) || is.na(selected_pkg$decision))) { @@ -363,7 +363,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { if (!(input$select_pkg == "-" && input$select_ver == "-" || (rlang::is_empty(selected_pkg$decision) || is.na(selected_pkg$decision))) && - "revert_decision" %in% credentials$privileges[[user$role]]) { + "revert_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) { shinyjs::hide("submit_decision") } else { shinyjs::show("submit_decision") @@ -375,7 +375,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { output$reset_decision_ui <- renderUI({ req(user$role) req(credentials$privileges) - req("revert_decision" %in% credentials$privileges[[user$role]]) + req("revert_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) req(!(input$select_pkg == "-" && input$select_ver == "-" || (rlang::is_empty(selected_pkg$decision) || is.na(selected_pkg$decision)))) @@ -385,7 +385,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { # Show a confirmation modal when submitting a decision. observeEvent(input$submit_decision, { req(input$decision) - req("final_decision" %in% credentials$privileges[[user$role]]) + req("final_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) showModal(modalDialog( size = "l", @@ -412,7 +412,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { # Show a confirmation modal when resetting a decision observeEvent(input$reset_decision, { req(input$decision) - req("revert_decision" %in% credentials$privileges[[user$role]]) + req("revert_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) showModal(modalDialog( size = "l", @@ -440,7 +440,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { # Update database info after decision is submitted. observeEvent(input$submit_confirmed_decision, { - req("final_decision" %in% credentials$privileges[[user$role]]) + req("final_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) dbUpdate("UPDATE package SET decision_id = {match(input$decision, golem::get_golem_options(\"decision_categories\"))}, decision_by = {user$name}, decision_date = {get_Date()} @@ -458,11 +458,11 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { loggit::loggit("INFO", glue::glue("decision for the package {selected_pkg$name} is {input$decision} - by {user$name} ({user$role})")) + by {user$name} ({paste(user$role, collapse = ', ')})")) }) observeEvent(input$reset_confirmed_decision, { - req("revert_decision" %in% credentials$privileges[[user$role]]) + req("revert_decision" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) dbUpdate("UPDATE package SET decision_id = NULL, decision_by = '', decision_date = NULL @@ -484,7 +484,7 @@ sidebarServer <- function(id, user, uploaded_pkgs, credentials) { loggit::loggit("INFO", glue::glue("decision for the package {selected_pkg$name} is reset - by {user$name} ({user$role})")) + by {user$name} ({paste(user$role, collapse = ', ')})")) }) # Output package id, name, and version. diff --git a/R/mod_uploadPackage.R b/R/mod_uploadPackage.R index f4a7b66c1..4cf531d96 100644 --- a/R/mod_uploadPackage.R +++ b/R/mod_uploadPackage.R @@ -85,7 +85,7 @@ uploadPackageUI <- function(id) { #' uploadPackageServer <- function(id, user, auto_list, credentials, parent) { if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer(id, function(input, output, session) { ns <- session$ns @@ -94,7 +94,7 @@ uploadPackageServer <- function(id, user, auto_list, credentials, parent) { req(user$role) req(credentials$privileges) - if ("add_package" %in% credentials$privileges[[user$role]]) { + if ("add_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) { shinyjs::enable("pkg_lst") shinyjs::enable("add_pkgs") shinyjs::enable("uploaded_file") @@ -108,7 +108,7 @@ uploadPackageServer <- function(id, user, auto_list, credentials, parent) { }) output$upload_format_lnk <- renderUI({ - req("add_package" %in% credentials$privileges[[user$role]]) + req("add_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) actionLink(NS(id, "upload_format"), "View Sample Dataset") }) @@ -119,9 +119,9 @@ uploadPackageServer <- function(id, user, auto_list, credentials, parent) { dplyr::bind_rows( upload_pkg, - if ("add_package" %in% credentials$privileges[[user$role]]) upload_pkg_add, - if ("delete_package" %in% credentials$privileges[[user$role]]) upload_pkg_delete, - if ("auto_decision_adjust" %in% credentials$privileges[[user$role]]) upload_pkg_dec_adj, + if ("add_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) upload_pkg_add, + if ("delete_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) upload_pkg_delete, + if ("auto_decision_adjust" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) upload_pkg_dec_adj, if (nrow(uploaded_pkgs()) > 0) upload_pkg_comp ) }) @@ -165,7 +165,7 @@ uploadPackageServer <- function(id, user, auto_list, credentials, parent) { output$rem_pkg_div <- renderUI({ req(user$role) req(credentials$privileges) - req("delete_package" %in% credentials$privileges[[user$role]]) + req("delete_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) session$onFlushed(function() { shinyjs::runjs(glue::glue('$("#{NS(id, "rem_pkg_btn")}").css("margin-top", $("#{NS(id, "rem_pkg_lst")}-label")[0].scrollHeight + .5*parseFloat(getComputedStyle(document.documentElement).fontSize))')) @@ -246,7 +246,7 @@ uploadPackageServer <- function(id, user, auto_list, credentials, parent) { }) observeEvent(input$rem_pkg_btn, { - req("delete_package" %in% credentials$privileges[[user$role]]) + req("delete_package" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) np <- length(input$rem_pkg_lst) uploaded_packages <- diff --git a/R/mod_user_roles.R b/R/mod_user_roles.R index 6cd56fbd2..1ec407d9e 100644 --- a/R/mod_user_roles.R +++ b/R/mod_user_roles.R @@ -29,10 +29,12 @@ mod_user_roles_ui <- function(id){ #' @noRd mod_user_roles_server <- function(id, user, credentials){ if (missing(credentials)) - credentials <- get_db_config("credentials") + credentials <- get_credential_config() moduleServer( id, function(input, output, session){ ns <- session$ns + use_shinymanager <- !isFALSE(get_db_config("use_shinymanager")) + initial_tbl <- get_roles_table() roles_dbtbl <- reactiveVal(initial_tbl) proxy_tbl <- reactiveVal() @@ -83,7 +85,7 @@ mod_user_roles_server <- function(id, user, credentials){ output$modal_table <- DT::renderDataTable({ i <- match("admin", rownames(roles_dbtbl())) - j <- match(role_changes() %>% dplyr::filter(old_role == user$role) %>% dplyr::pull(new_role), colnames(roles_dbtbl())) + j <- match(role_changes() %>% dplyr::filter(old_role %in% user$role) %>% dplyr::pull(new_role), colnames(roles_dbtbl())) DT::datatable( roles_dbtbl(), escape = FALSE, @@ -103,7 +105,6 @@ mod_user_roles_server <- function(id, user, credentials){ " var value = $(this).is(':checked') ? 1 : 0", " var info = [{row: row, col: col, value: value}]", glue::glue(" Shiny.setInputValue('{ns(\"modal_table\")}_cell_edit:DT.cellInfo', info)"), - " console.log(info)", " })", "}" ), @@ -114,8 +115,10 @@ mod_user_roles_server <- function(id, user, credentials){ targets = "_all", render = DT::JS(glue::glue( "function(data, type, row, meta) {{", + " var cols = {jsonlite::toJSON(j)};", " if(meta.col != 0){{", - " return ``;", + " console.log(row);", + " return ` {{return rsum + row[x]}}, 0) === 1 & cols.includes(meta.col) & data ? 'disabled' : ''}} row=${{meta.row}} col=${{meta.col}} ${{data ? 'checked' : ''}}/>`;", " }}", " return data;", "}}" @@ -126,8 +129,24 @@ mod_user_roles_server <- function(id, user, credentials){ bindEvent(roles_dbtbl()) observeEvent(input$edit_dropdown, { - user_table(get_credentials_table(passphrase = passphrase)) - used_roles <- role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + user_table({ + if (!use_shinymanager) + dbSelect("SELECT user_role AS role FROM roles") %>% + dplyr::filter(role %in% c(user$role, "default")) + else + get_credentials_table(passphrase = passphrase) + }) + used_roles <- + if (!use_shinymanager) { + unique(c(user$role, "default")) + } else { + role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + } + used_roles_admin <- + intersect(names(purrr::keep(credentials$privileges, ~ "admin" %in% .x)), user$role) %>% + c("default") %>% + unique() + showModal(modalDialog( size = "l", footer = tagList( @@ -148,16 +167,16 @@ mod_user_roles_server <- function(id, user, credentials){ tags$label("Edit Role Name", class = "control-label"), div( style = "display: flex", - selectInput(ns("select_edit_col"), NULL, choices = colnames(proxy_tbl()), width = "25%"), + selectInput(ns("select_edit_col"), NULL, choices = if (use_shinymanager) colnames(proxy_tbl()) else setdiff(colnames(proxy_tbl()), used_roles), width = "25%"), textInput(ns("edit_col"), NULL, width = "25%"), actionButton(ns("edit_col_submit"), shiny::icon("pen-to-square"), style = 'height: calc(1.5em + 1.5rem + 2px)') ), - tags$label("Delete Role", icon("circle-info", class = "fa-xs", title = "A role can only be deleted if no users are assigned to it. If the role is not visible, first ensure no users are assigned that role in the Credential Manager."), class = "control-label"), + tags$label("Delete Role", icon("circle-info", class = "fa-xs", title = if (use_shinymanager) "A role can only be deleted if no users are assigned to it. If the role is not visible, first ensure no users are assigned that role in the Credential Manager." else "A role/group can only be deleted if you as the user are not assigned it and it is not the default."), class = "control-label"), div( style = "display: flex", - selectInput(ns("delete_col"), NULL, choices = setdiff(colnames(proxy_tbl()), used_roles), width = "50%") %>% - tagAppendAttributes(class = if(length(setdiff(colnames(proxy_tbl()), used_roles)) == 0) "shinyjs-disabled"), + selectInput(ns("delete_col"), NULL, choices = setdiff(colnames(proxy_tbl()), if (use_shinymanager) used_roles else used_roles_admin), width = "50%") %>% + tagAppendAttributes(class = if(length(setdiff(colnames(proxy_tbl()), if (use_shinymanager) used_roles else used_roles_admin)) == 0) "shinyjs-disabled"), actionButton(ns("delete_col_submit"), shiny::icon("trash-can"), style = 'height: calc(1.5em + 1.5rem + 2px)') ), @@ -178,13 +197,22 @@ mod_user_roles_server <- function(id, user, credentials){ reset_table <- get_roles_table() roles_dbtbl(reset_table) role_changes(dplyr::tibble(old_role = colnames(reset_table), new_role = colnames(reset_table))) - used_roles <- role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + used_roles <- + if (!use_shinymanager) { + unique(c(user$role, "default")) + } else { + role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + } + used_roles_admin <- + intersect(names(purrr::keep(credentials$privileges, ~ "admin" %in% .x)), user$role) %>% + c("default") %>% + unique() updateTextInput(session, "add_col", value = "") - updateSelectInput(session, "select_edit_col", choices = colnames(reset_table)) + updateSelectInput(session, "select_edit_col", choices = if (use_shinymanager) colnames(reset_table) else setdiff(colnames(reset_table), used_roles)) updateTextInput(session, "edit_col", value = "") - updateSelectInput(session, "delete_col", choices = setdiff(colnames(reset_table), used_roles)) - if (length(setdiff(colnames(reset_table), used_roles)) == 0) + updateSelectInput(session, "delete_col", choices = setdiff(colnames(reset_table), if (use_shinymanager) used_roles else used_roles_admin)) + if (length(setdiff(colnames(reset_table), if (use_shinymanager) used_roles else used_roles_admin)) == 0) shinyjs::disable("delete_col") else shinyjs::enable("delete_col") @@ -193,7 +221,13 @@ mod_user_roles_server <- function(id, user, credentials){ observeEvent(input$modal_table_cell_edit, { i <- match("admin", rownames(roles_dbtbl())) j <- match(user$role, colnames(roles_dbtbl())) - req(i != input$modal_table_cell_edit$row || j != input$modal_table_cell_edit$col) + req(i != input$modal_table_cell_edit$row || + i == input$modal_table_cell_edit$row & + sum(proxy_tbl()[i, j]) > 1 || + i == input$modal_table_cell_edit$row & + sum(proxy_tbl()[i, j]) == 1 & + input$modal_table_cell_edit$value == 1 || + !input$modal_table_cell_edit$col %in% j) proxy_tbl(DT::editData(proxy_tbl(), input$modal_table_cell_edit)) DT::replaceData(proxy, proxy_tbl(), resetPaging = FALSE) @@ -207,12 +241,21 @@ mod_user_roles_server <- function(id, user, credentials){ colnames(tbl) <- c(colnames(proxy_tbl()), input$add_col) roles_dbtbl(tbl) role_changes(dplyr::add_row(role_changes(), new_role = input$add_col)) - used_roles <- role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + used_roles <- + if (!use_shinymanager) { + unique(c(user$role, "default")) + } else { + role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + } + used_roles_admin <- + intersect(names(purrr::keep(credentials$privileges, ~ "admin" %in% .x)), user$role) %>% + c("default") %>% + unique() updateTextInput(session, "add_col", value = "") - updateSelectInput(session, "select_edit_col", choices = colnames(tbl)) + updateSelectInput(session, "select_edit_col", choices = if (use_shinymanager) colnames(tbl) else setdiff(colnames(tbl), used_roles)) updateTextInput(session, "edit_col", value = "") - updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), used_roles)) + updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), if (use_shinymanager) used_roles else used_roles_admin)) shinyjs::enable("delete_col") }) @@ -229,40 +272,58 @@ mod_user_roles_server <- function(id, user, credentials){ new_role = if_else(new_role == input$select_edit_col, input$edit_col, new_role))) - used_roles <- role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + used_roles <- + if (!use_shinymanager) { + unique(c(user$role, "default")) + } else { + role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + } + used_roles_admin <- + intersect(names(purrr::keep(credentials$privileges, ~ "admin" %in% .x)), user$role) %>% + c("default") %>% + unique() updateTextInput(session, "add_col", value = "") - updateSelectInput(session, "select_edit_col", choices = colnames(tbl)) + updateSelectInput(session, "select_edit_col", choices = if (use_shinymanager) colnames(tbl) else setdiff(colnames(tbl), used_roles)) updateTextInput(session, "edit_col", value = "") - updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), used_roles)) + updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), if (use_shinymanager) used_roles else used_roles_admin)) }) observeEvent(input$delete_col_submit, { o_role <- role_changes() %>% dplyr::filter(new_role == input$delete_col) %>% dplyr::pull(name = old_role) - req(!o_role %in% user_table()$role) + used_roles_admin <- + intersect(names(purrr::keep(credentials$privileges, ~ "admin" %in% .x)), user$role) %>% + c("default") %>% + unique() + req(!o_role %in% if (use_shinymanager) user_table()$role else used_roles_admin) tbl <- proxy_tbl() i <- match(input$delete_col, colnames(tbl)) - tbl <- tbl[,-i] + tbl <- tbl[,-i, drop = FALSE] roles_dbtbl(tbl) role_changes(dplyr::mutate(role_changes(), new_role = if_else(new_role == input$delete_col, NA_character_, new_role))) - used_roles <- role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + used_roles <- + if (!use_shinymanager) { + unique(c(user$role, "default")) + } else { + role_changes() %>% dplyr::filter(old_role %in% user_table()$role) %>% dplyr::pull(new_role) + } updateTextInput(session, "add_col", value = "") - updateSelectInput(session, "select_edit_col", choices = colnames(tbl)) + updateSelectInput(session, "select_edit_col", choices = if (use_shinymanager) colnames(tbl) else setdiff(colnames(tbl), used_roles)) updateTextInput(session, "edit_col", value = "") - updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), used_roles)) - if (length(setdiff(colnames(tbl), used_roles)) == 0) + updateSelectInput(session, "delete_col", choices = setdiff(colnames(tbl), if (use_shinymanager) used_roles else used_roles_admin)) + if (length(setdiff(colnames(tbl), if (use_shinymanager) used_roles else used_roles_admin)) == 0) shinyjs::disable("delete_col") else shinyjs::enable("delete_col") }) observeEvent(input$submit_changes, { - req("admin" %in% credentials$privileges[[user$role]]) + req("admin" %in% unlist(credentials$privileges[user$role], use.name = FALSE)) chng_lst <- dplyr::filter(role_changes(), paste(old_role) != paste(new_role)) purrr::pmap(chng_lst, function(old_role, new_role) { @@ -275,24 +336,36 @@ mod_user_roles_server <- function(id, user, credentials){ }) purrr::iwalk(as.data.frame(proxy_tbl()), ~ dbUpdate(glue::glue("UPDATE roles SET {paste(used_privileges, ' = ', .x, collapse = ', ')} WHERE user_role = '{.y}'"))) - updated_user_tbl <- - user_table() %>% - dplyr::rowwise() %>% - dplyr::mutate( - role = role_changes() %>% `[`(!is.na(.$old_role) & .$old_role == role, "new_role") %>% `[[`(1), - admin = purrr::map(role, ~ dplyr::if_else(proxy_tbl()["admin", .x] == 1, 'TRUE', 'FALSE')) %>% unlist() - ) - set_credentials_table(updated_user_tbl, passphrase = passphrase) - - user$role <- role_changes() %>% `[`(!is.na(.$old_role) & .$old_role == user$role, "new_role") %>% `[[`(1) + if (use_shinymanager) { + updated_user_tbl <- + user_table() %>% + dplyr::rowwise() %>% + dplyr::mutate( + role = role_changes() %>% `[`(!is.na(.$old_role) & .$old_role == role, "new_role") %>% `[[`(1), + admin = purrr::map(role, ~ dplyr::if_else(proxy_tbl()["admin", .x] == 1, 'TRUE', 'FALSE')) %>% unlist() + ) + set_credentials_table(updated_user_tbl, passphrase = passphrase) + } + + user$role <- role_changes() %>% `[`(!is.na(.$old_role) & .$old_role %in% user$role, "new_role") %>% `[[`(1) update_tbl <- get_roles_table() roles_dbtbl(update_tbl) role_changes(dplyr::tibble(old_role = colnames(update_tbl), new_role = colnames(update_tbl))) purrr::iwalk(get_credential_config(), ~ `<-`(credentials[[.y]], .x)) + + user_table({ + if (!use_shinymanager) + dbSelect("SELECT user_role AS role FROM roles") %>% + dplyr::filter(role %in% c(user$role, "default")) + else + get_credentials_table(passphrase = passphrase) + }) - user_table(get_credentials_table(passphrase = passphrase)) + # Make sure the user roles are reflected with changes + if (!use_shinymanager) + user$role <- intersect(unlist(session$groups, use.names = FALSE), dbSelect("select user_role from roles")[[1]]) %||% c("default") session$userData$trigger_events[["reset_sidebar"]] <- session$userData$trigger_events[["reset_sidebar"]] + 1 diff --git a/R/utils.R b/R/utils.R index 259d8a16c..b9f22454e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -522,7 +522,7 @@ remove_shiny_inputs <- function(id, .input, ns = NS(NULL)) { #' Function to substitute left-hand side with right-hand side if NULL #' #' @noRd -`%||%` <- function(lhs, rhs) if (is.null(lhs)) rhs else lhs +`%||%` <- function(lhs, rhs) if (rlang::is_empty(lhs)) rhs else lhs #' shinyInput diff --git a/R/utils_config_db.R b/R/utils_config_db.R index 63c41d7da..e8cd78d3a 100644 --- a/R/utils_config_db.R +++ b/R/utils_config_db.R @@ -30,7 +30,7 @@ configure_db <- function(dbname, config) { check_decision_config(config[["decisions"]]) if (!is.null(config[["metric_weights"]])) check_metric_weights(config[["metric_weights"]]) - check_credentials(config[["credentials"]]) + config[["credentials"]] <- check_credentials(config[["credentials"]]) # Set decision categories purrr::walk(config[["decisions"]]$categories, ~ dbUpdate("INSERT INTO decision_categories (decision) VALUES ({.x})", dbname)) @@ -215,12 +215,21 @@ check_credentials <- function(credentials_lst) { if (!"admin" %in% privileges) stop("The roles corresponding to 'admin' privileges must be specified") + if (isFALSE(get_db_config("use_shinymanger"))) { + if (!"default" %in% credentials_lst$roles) { + credentials_lst$roles <- c(credentials_lst$roles, "default") + warning("When using {riskassessment} without {shinymanger}, the role 'default' is mandatory. If omitted in `db-config.yml`, it will be initialized with no privileges.") + } + } + if (!all(privileges_roles %in% credentials_lst$roles)) warning(glue::glue("The following role(s) designated under privileges is(are) not present in the 'roles' configuration: {paste(privileges_roles[!privileges_roles %in% credentials_lst$roles], collapse = ', ')}")) valid_privileges <- unique(unlist(credentials_lst$privileges[credentials_lst$roles], use.names = FALSE)) if (!all(used_privileges %in% valid_privileges)) warning(glue::glue("The following privilege(s) is(are) not assigned to any 'role' in the credentials configuration: {paste(used_privileges[!used_privileges %in% valid_privileges], collapse = ', ')}")) + + credentials_lst } parse_rules <- function(dec_config) { diff --git a/R/utils_startup.R b/R/utils_startup.R index 68cb30865..09fb2dfea 100644 --- a/R/utils_startup.R +++ b/R/utils_startup.R @@ -188,19 +188,22 @@ initialize_raa <- function(assess_db, cred_db, configuration) { if (isTRUE(getOption("shiny.testmode"))) return(NULL) db_config <- if(missing(configuration)) get_db_config(NULL) else configuration - used_configs <- c("assessment_db", "credential_db", "decisions", "credentials", "loggit_json", "metric_weights", "report_prefs", "package_repo") + used_configs <- c("assessment_db", "credential_db", "decisions", "credentials", "loggit_json", "metric_weights", "report_prefs", "package_repo", "use_shinymanager") if (any(!names(db_config) %in% used_configs)) { names(db_config) %>% `[`(!. %in% used_configs) %>% purrr::walk(~ warning(glue::glue("Unknown database configuration '{.x}' found in db-config.yml"))) } + use_shinymanager <- !isFALSE(db_config[["use_shinymanager"]]) + assessment_db <- if (missing(assess_db)) get_db_config("assessment_db") else assess_db - credentials_db <- if (missing(cred_db)) golem::get_golem_options('credentials_db_name') else cred_db + if (use_shinymanager) + credentials_db <- if (missing(cred_db)) golem::get_golem_options('credentials_db_name') else cred_db if (is.null(assessment_db) || typeof(assessment_db) != "character" || length(assessment_db) != 1 || !grepl("\\.sqlite$", assessment_db)) stop("assess_db must follow SQLite naming conventions (e.g. 'database.sqlite')") - if (!isTRUE(getOption("shiny.testmode")) && (is.null(credentials_db) || typeof(credentials_db) != "character" || length(credentials_db) != 1 || !grepl("\\.sqlite$", credentials_db))) + if (use_shinymanager && !isTRUE(getOption("shiny.testmode")) && (is.null(credentials_db) || typeof(credentials_db) != "character" || length(credentials_db) != 1 || !grepl("\\.sqlite$", credentials_db))) stop("cred_db must follow SQLite naming conventions (e.g. 'database.sqlite')") # Start logging info. @@ -214,16 +217,16 @@ initialize_raa <- function(assess_db, cred_db, configuration) { check_repos(db_config[["package_repo"]]) - if (file.exists(assessment_db) & (isTRUE(getOption("shiny.testmode")) | file.exists(credentials_db))) - return(invisible(c(assessment_db, if (!isTRUE(getOption("shiny.testmode"))) credentials_db))) + if (file.exists(assessment_db) && (isTRUE(getOption("shiny.testmode")) || use_shinymanager && file.exists(credentials_db))) + return(invisible(c(assessment_db, if (!isTRUE(getOption("shiny.testmode")) & use_shinymanager) credentials_db))) check_credentials(db_config[["credentials"]]) - if (isFALSE(getOption("golem.app.prod")) && !is.null(golem::get_golem_options('pre_auth_user')) && !file.exists(credentials_db)) create_credentials_dev_db(credentials_db) + if (use_shinymanager && isFALSE(getOption("golem.app.prod")) && !is.null(golem::get_golem_options('pre_auth_user')) && !file.exists(credentials_db)) create_credentials_dev_db(credentials_db) # Create package db & credentials db if it doesn't exist yet. if(!file.exists(assessment_db)) create_db(assessment_db) - if(!file.exists(credentials_db)) { + if(use_shinymanager && !file.exists(credentials_db)) { admin_role <- db_config[["credentials"]][["privileges"]] %>% purrr::imap(~ if ("admin" %in% .x) .y) %>% unlist(use.names = FALSE) %>% @@ -243,7 +246,7 @@ initialize_raa <- function(assess_db, cred_db, configuration) { if (!dir.exists("tarballs")) dir.create("tarballs") if (!dir.exists("source")) dir.create("source") - invisible(c(assessment_db, credentials_db)) + invisible(c(assessment_db, if (use_shinymanager) credentials_db)) } #' Check CRAN repos @@ -362,7 +365,8 @@ add_tags <- function(ui, ...) { #' @md #' @keywords internal add_shinymanager_auth <- function(app_ui, app_ver, login_note) { - if (!isTRUE(getOption("shiny.testmode"))) { + # Don't add shinymanager if running the application in testing mode or without credentials + if (!isTRUE(getOption("shiny.testmode")) && !isFALSE(get_db_config("use_shinymanager"))) { add_tags(shinymanager::secure_app(app_ui, tags_top = tags$div( tags$head(favicon(), tags$style(HTML(readLines(app_sys("app/www/css", "login_screen.css"))))), diff --git a/inst/WORDLIST b/inst/WORDLIST index 20246bcc4..57adb0993 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -17,6 +17,7 @@ MetricBox Munshi PR's PeterParker +Pkgs Preload RSPM RStudio @@ -80,14 +81,14 @@ px renv repo repo's -repo’s reportDownload -riskcalc +repo’s riskmetric rstudio serverless shinyapps shinylogs +shinymanager shinytest showComments showHelperMessage @@ -102,4 +103,3 @@ userid viewComment www ’s - \ No newline at end of file diff --git a/inst/db-config.yml b/inst/db-config.yml index 0fee69da4..923d14eaa 100644 --- a/inst/db-config.yml +++ b/inst/db-config.yml @@ -2,6 +2,7 @@ default: package_repo: https://cran.rstudio.com assessment_db: database.sqlite loggit_json: loggit.json + use_shinymanager: true credential_db: credentials.sqlite report_prefs: directory: report_preferences @@ -74,3 +75,11 @@ example2: - GxP Compliant - Needs Review - Not GxP Compliant +noncredentialed: + use_shinymanager: false + assessment_db: database_noncredentialed.sqlite + credentials: + roles: + - default + privileges: + default: [admin, weight_adjust, auto_decision_adjust, final_decision, revert_decision, add_package, delete_package, overall_comment, general_comment] diff --git a/tests/testthat/test-apps/decision_automation-app/app.R b/tests/testthat/test-apps/decision_automation-app/app.R index cad42e4d7..42df1a76f 100644 --- a/tests/testthat/test-apps/decision_automation-app/app.R +++ b/tests/testthat/test-apps/decision_automation-app/app.R @@ -18,7 +18,7 @@ server <- function(input, output, session) { user <- reactiveValues( name = "tester", - role = "admin" + role = "reweighter" ) auto_decision <- riskassessment:::mod_decision_automation_server("automate", user) diff --git a/tests/testthat/test-utils_config_checkers.R b/tests/testthat/test-utils_config_checkers.R index 46c1d56fe..b098d9cd2 100644 --- a/tests/testthat/test-utils_config_checkers.R +++ b/tests/testthat/test-utils_config_checkers.R @@ -133,9 +133,10 @@ test_that("check_credentials works", { fixed = TRUE ) + test_creds <- list(roles = c("admin", "lead", "reviewer"), privileges = list(admin = used_privileges)) expect_equal( - check_credentials(list(roles = c("admin", "lead", "reviewer"), privileges = list(admin = used_privileges))), - NULL + check_credentials(test_creds), + test_creds ) })