Merge pull request #34 from openpharma/033_alternative_login_options

Ensure other authentication options can be used

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: clinsight
 Title: ClinSight
-Version: 0.0.0.9002
+Version: 0.0.0.9003
 Authors@R: c(
     person("Leonard Daniël", "Samson", , "[email protected]", role = c("cre", "aut")),
     person("GCP-Service International Ltd.& Co. KG", role = "fnd")

R/app_authentication.R

@@ -14,10 +14,10 @@ initialize_credentials <- function(
 ){
   if(file.exists(credentials_db)) return(
     cat("Using existing credentials database.\n")
-    )
+  )
 
   cat("No credentials database found. Initializing new database.\n", 
-          "Login with Username 'admin' and Password '1234'.")
+      "Login with Username 'admin' and Password '1234'.")
   con <- get_db_connection(credentials_db)
   initial_credentials <- data.frame(
     "user"     = "admin", 
@@ -58,14 +58,10 @@ initialize_credentials <- function(
 
 #' Authenticate UI
 #'
-#' Authentication implementation in the UI.
-#'
-#' @param test_mode Logical. Whether the app should be started in test mode or
-#'   not.
+#' Authentication implementation in the UI, using `shinymanager`.
 #'
 #' 
-authenticate_ui <- function(test_mode = FALSE){
-  if (test_mode) return(app_ui) 
+authenticate_ui <- function(){
   shinymanager::secure_app(
     app_ui, 
     enable_admin = TRUE, 
@@ -92,45 +88,87 @@ authenticate_ui <- function(test_mode = FALSE){
 #'
 #' Function to authenticate the main server.
 #'
-#' @param test_mode Logical, whether to start the application in test mode.
-#' @param sites Character vector. Study sites that can be allocated to a user.
-#' @param roles Character vector. Roles that can be allocated to a user.
-#' @param credentials_db Character vector. Path to the credentials
-#'   database.
-#' @param credentials_pwd Character vector, containing the database
-#'   password.
+#' @param user_identification Character vector showing the user identification.
+#'   Is by default set by the `user_identification` option in the `golem-config`
+#'   file.
+#' @param credentials_db Character vector. Path to the credentials database. By
+#'   default, set by the `data_folder` and `credentials_db` options in the
+#'   `golem-config_file`.
+#' @param credentials_pwd Character vector, containing the database password.
+#' @param all_sites Character vector with all sites. Will be passed on to
+#'   shinymanager configuration so that data can be restricted to specific sites
+#'   per user.
+#' @param all_roles Character vector with all roles. Used to show all applicable
+#'   roles in `shinymanager` admin mode.
+#' @param user_id Character vector. Used to retrieve the user ID from the
+#'   session object, if applicable.
+#' @param user_name Character vector. Used to retrieve the user name from the
+#'   session object, if applicable.
+#' @param user_group Used to retrieve the user group from the session object, if
+#'   applicable.
+#' @param session Shiny session. Needed to access user information in case of
+#'   login methods alternative to `shinymanager` are used.
 #' 
 authenticate_server <- function(
-    test_mode = FALSE, 
-    sites = app_vars$Sites$site_code,
-    roles = c("Medical Monitor", "Data Manager", "Administrator", "Investigator"),
-    credentials_db = app_sys("app/www/credentials_db.sqlite"),
-    credentials_pwd = Sys.getenv("DB_SECRET")
-){
-  if (test_mode) return({
-    # To skip authentication when testing application:
-    reactiveValues(
-      admin = TRUE,
-      user = "test_user",
-      name = "test user", 
-      role = "Medical monitor",
-      sites = sites
-    )
-  }) 
-  shinymanager::secure_server(
-    check_credentials = shinymanager::check_credentials(
-      credentials_db,
-      passphrase = credentials_pwd
+    user_identification = get_golem_config("user_identification"),
+    all_sites = NULL,
+    all_roles = get_golem_config("group_roles"),
+    credentials_db = file.path(
+      get_golem_config("data_folder"), 
+      get_golem_config("credentials_db")
     ),
-    inputs_list = list(
-      "role" = list(
-        fun = "selectInput", 
-        args = list(choices = roles, multiple = TRUE) 
+    credentials_pwd = Sys.getenv("DB_SECRET"), 
+    user_id = get_golem_config("user_id"),
+    user_name = get_golem_config("user_name"),
+    user_group = get_golem_config("user_group"),
+    session
+){
+  switch(
+    user_identification,
+    shinymanager = shinymanager::secure_server(
+      check_credentials = shinymanager::check_credentials(
+        credentials_db,
+        passphrase = credentials_pwd
       ),
-      "sites" = list(
-        fun = "selectInput",
-        args = list(label = NULL, choices = sites, selected = sites, multiple = TRUE)
+      inputs_list = list(
+        "role" = list(
+          fun = "selectInput", 
+          args = list(choices = all_roles, multiple = TRUE) 
+        ),
+        "sites" = list(
+          fun = "selectInput",
+          args = list(
+            label = NULL, 
+            choices = all_sites, 
+            selected = all_sites, 
+            multiple = TRUE
+          )
+        )
       )
+    ),
+    test_user = reactiveValues(
+      user = "test_user", 
+      name = "test user", 
+      role = all_roles[1],
+      sites = all_sites
+    ),
+    http_headers = reactiveValues(
+      user = session$request$HTTP_X_SP_USERID,
+      name = session$request$HTTP_X_SP_USERNAME,
+      role = session$request$HTTP_X_SP_USERGROUPS,
+      sites = all_sites
+    ),
+    shiny_session = reactiveValues(
+      user = session$user,
+      name = session$user,
+      role = session$groups,
+      sites = all_sites
+    ),
+    reactiveValues(
+      user = "Unknown",
+      name = "Unknown",
+      role = "Unknown",
+      sites = all_sites
     )
-  ) 
+  )
 }

R/app_server.R

@@ -21,7 +21,6 @@ app_server <- function(
   merged_data <- golem::get_golem_options("data")
   user_db <- golem::get_golem_options("user_db")
   credentials_db <- golem::get_golem_options("credentials_db")
-  test_mode <- golem::get_golem_options("test_mode")
 
   app_data <- get_appdata(merged_data, meta = meta)
   app_vars <- get_meta_vars(data = app_data, meta = meta)
@@ -32,16 +31,12 @@ app_server <- function(
   check_appdata(app_data, meta)
 
   res_auth <- authenticate_server(
-    test_mode = test_mode,
-    sites = app_vars$Sites$site_code,  
+    all_sites = app_vars$Sites$site_code, 
     credentials_db = credentials_db,
-    credentials_pwd = golem::get_golem_options("credentials_pwd")
+    credentials_pwd = golem::get_golem_options("credentials_pwd"),
+    session = session
     )
 
-  output$user_info <- renderText({
-    res_auth[["name"]]
-  })
-
   # load tabs in UI:
   common_forms <- with(app_vars$all_forms, form[main_tab == "Common events"])
   lapply(common_forms, \(i){
@@ -88,6 +83,10 @@ app_server <- function(
     subject_id        = app_vars$subject_id[1]
   )
 
+  output$user_info <- renderText({
+    req(r$user_name())
+    r$user_name()
+  })
   rev_sites <- reactive({res_auth[["sites"]]})
   observeEvent(rev_sites(), {
     r <- filter_data(r, rev_sites(), subject_ids = app_vars$subject_id,
@@ -195,12 +194,11 @@ app_server <- function(
     navinfo = navinfo, 
     events = meta$events
     )
-
+  
   # Only initiate the sidebar after successful login, because it contains a
   # modal that pops up if data is out of synch. Modals interfere with shinymanager.
-  observeEvent(res_auth[["name"]], {
-    req(!is.null(res_auth[["name"]]))
-    if(!test_mode){
+  observeEvent(r$user_name, {
+    if(isTRUE(get_golem_config("user_identification") == "shinymanager")){
       pwd_mngt <- shinymanager::read_db_decrypt(
         get_db_connection(credentials_db), 
         name = "pwd_mngt",
@@ -219,8 +217,7 @@ app_server <- function(
         with(rev_data$summary(), Form[subject_id == r$subject_id])
       }),
       db_path = user_db,
-      available_data = available_data,
-      test_mode = test_mode
+      available_data = available_data
     )
   })
 

R/fct_utils.R

@@ -579,7 +579,7 @@ get_test_results <- function(
     "session" = utils::sessionInfo()
   )
   if(is.null(outfile)) return(test_results)
-  cat("Finished unit testing. Results: \n")
+  cat("\n\n----------------------------\n\nFinished unit testing. Results: \n")
   # Summary is nice to have but should not give a fatal error: 
   tryCatch({
     # TODO: maybe import testthat:::as.data.frame.testthat_results?
@@ -594,5 +594,6 @@ get_test_results <- function(
   if(file.exists(outfile)){
     cat("Output created successfully in ", outfile, "\n") 
   }
+  cat("\n----------------------------\n\n")
 }
 

R/global.R

@@ -17,7 +17,7 @@ global <- quote({
     if(!file.exists(data_local)) stop("Could not save data set locally.")
     data_synched <- TRUE
   }
-  Sys.setenv("GOLEM_CONFIG_ACTIVE" = "production")
+  Sys.setenv("GOLEM_CONFIG_ACTIVE" = "shinymanager")
   run_app(data_folder = data_folder)
 })
 

R/mod_db_synch_info.R

@@ -31,23 +31,28 @@ mod_db_synch_info_ui <- function(id){
 #' @param db_path Character vector with the path to the app database. Required
 #'   to retrieve the latest database synch date that is stored in the data frame
 #'   "db_synch_time".
-#' @param test_mode Logical. If TRUE, a fixed date (2024-01-10) will be chosen
-#'   as current date, This way, the module can be tested consistently. Can be
-#'   replaced and removed as soon as mocking is available within `shinytest2`.
-#' @param show_warning Logical. Whether to show a pop-up message with a warning
-#'   if database synchronization did not happen on the current day. Useful to
-#'   be able to turn off the message for testing purposes.
+#' @param current_date Current date. Standard `Sys.Date()`. Can be useful to set
+#'   for testing purposes.
+#' @param show_synch_warning Logical. Whether to show a pop-up message with a
+#'   warning if database synchronization did not happen on the current day. Will
+#'   normally be shown if in the configuration the app is set to production.
 #'
 #' @seealso [mod_db_synch_info_ui()]
-mod_db_synch_info_server <- function(id, app_data, db_path, test_mode, show_warning = TRUE){
+mod_db_synch_info_server <- function(
+    id, 
+    app_data, 
+    db_path, 
+    current_date = Sys.Date(),
+    show_synch_warning = isTRUE(get_golem_config("app_prod"))
+    ){
   stopifnot(is.list(app_data))
   stopifnot(is.character(db_path))
+  stopifnot(is_date(current_date))
+  stopifnot(is.logical(show_synch_warning))
+
   moduleServer( id, function(input, output, session){
     ns <- session$ns
 
-    # below allows consistent snapshot testing with a fixed current date:
-    current_date <- if (test_mode) as.Date("2024-01-10") else Sys.Date()
-
     synch_time <- reactive({
       tryCatch({
         if(!file.exists(db_path)) dbt <- NULL else{
@@ -72,7 +77,7 @@ mod_db_synch_info_server <- function(id, app_data, db_path, test_mode, show_warn
     # hack to be able to test the db_synch date:
 
     synch_warning <- reactive({
-      req(synch_time(), show_warning)
+      req(synch_time(), show_synch_warning)
       if(synch_time() == "Unknown") return({
         paste0(
           "The latest database synchronization date is <b>Unknown</b>.<br>",

R/mod_main_sidebar.R

@@ -67,7 +67,6 @@ mod_main_sidebar_ui <- function(id){
 #'   created with the function [get_available_data()]. The data frame will be
 #'   passed on to the module [mod_query_add_server()], which requires this data
 #'   frame and is embedded in `mod_main_sidebar_server()`.
-#' @param test_mode Logical. Required for testing [mod_db_synch_info_server()].
 #'
 #' @seealso [mod_main_sidebar_ui()], [mod_query_add_server()]
 #' 
@@ -80,8 +79,7 @@ mod_main_sidebar_server <- function(
     app_vars,
     db_path, 
     forms_to_review,
-    available_data,
-    test_mode
+    available_data
 ){
   stopifnot(is.reactivevalues(r))
 
@@ -137,9 +135,7 @@ mod_main_sidebar_server <- function(
     mod_db_synch_info_server(
       id = "synch_info",
       app_data = app_data,
-      db_path = db_path,
-      test_mode = test_mode,
-      show_warning = !test_mode
+      db_path = db_path
       )
   })
 }