From 9d018980925ca34462d14ef1a7c5e7c8ecee10bf Mon Sep 17 00:00:00 2001 From: bthieurmel Date: Fri, 27 Mar 2020 11:26:48 +0100 Subject: [PATCH] Fix choose / pass language + simultaneous admin --- DESCRIPTION | 2 +- NAMESPACE | 2 + NEWS.md | 4 +- R/language.R | 107 ++++++++++++++++------------- R/module-admin.R | 127 +++++++++++++++++++---------------- R/module-auth.R | 46 ++++++++----- R/module-edit_user.R | 6 +- R/module-pwd.R | 32 ++++++--- R/modules-logs.R | 15 +++-- R/secure-app.R | 50 +++++++++----- R/shiny-utils.R | 27 ++++++-- examples/demo/global.R | 6 ++ man/custom-labels.Rd | 7 +- man/module-authentication.Rd | 23 ++++++- man/module-password.Rd | 18 +++-- man/secure-app.Rd | 19 ++++-- 16 files changed, 316 insertions(+), 175 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2b79433..054062e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: shinymanager Title: Authentication Management for 'Shiny' Applications -Version: 1.0.210 +Version: 1.0.215 Authors@R: c( person("Benoit", "Thieurmel", email = "benoit.thieurmel@datastorm.fr", role = c("aut", "cre")), person("Victor", "Perrier", email = "victor.perrier@dreamRs.fr", role = c("aut")) diff --git a/NAMESPACE b/NAMESPACE index f223106..877847d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,7 @@ importFrom(shiny,getQueryString) importFrom(shiny,icon) importFrom(shiny,insertUI) importFrom(shiny,invalidateLater) +importFrom(shiny,is.reactive) importFrom(shiny,isolate) importFrom(shiny,modalButton) importFrom(shiny,modalDialog) @@ -77,6 +78,7 @@ importFrom(shiny,outputOptions) importFrom(shiny,parseQueryString) importFrom(shiny,passwordInput) importFrom(shiny,reactive) +importFrom(shiny,reactiveFileReader) importFrom(shiny,reactiveVal) importFrom(shiny,reactiveValues) importFrom(shiny,reactiveValuesToList) diff --git a/NEWS.md b/NEWS.md index e0be2c3..857f7c1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# shinymanager 1.0.210 +# shinymanager 1.0.215 * Add ``autofocus`` on username input. * Fix some (strange) bug with ``input$shinymanager_where`` @@ -6,6 +6,8 @@ * `auth_ui()` now accept a `choose_language` arguments. * Rename `br` language into `pt-BR` (iso code) * add user info in downloaded log file +* add `set_labels()` for customize labels +* Fix simultaneous admin session # shinymanager 1.0.200 diff --git a/R/language.R b/R/language.R index 19744f8..7a3e841 100644 --- a/R/language.R +++ b/R/language.R @@ -1,7 +1,6 @@ +pkgEnv <- new.env() -.globals <- new.env(parent = emptyenv()) - -.label_en = list( +pkgEnv$label_en = list( "Please authenticate" = "Please authenticate", "Username:" = "Username:", "Password:" = "Password:", @@ -26,6 +25,7 @@ "Confirm change" = "Confirm change", "Are you sure to remove user(s): %s from the database ?" = "Are you sure to remove user(s): %s from the database ?", "Delete user(s)" = "Delete user(s)", + "Delete user" = "Delete user", "Edit user" = "Edit user", "User already exist!" = "User already exist!", "Dismiss" = "Dismiss", @@ -55,12 +55,13 @@ "Download logs database" = "Download logs database", "Download SQL database" = "Download SQL database", "Reset password for %s?" = "Reset password for %s?", + "Reset password" = "Reset password", "Temporary password:" = "Temporary password:", "Password succesfully reset!" = "Password succesfully reset!", "You are not authorized for this application" = "You are not authorized for this application" ) -.label_fr = list( +pkgEnv$label_fr = list( "Please authenticate" = "Veuillez vous authentifier", "Username:" = "Nom d\'utilisateur :", "Password:" = "Mot de passe :", @@ -85,6 +86,7 @@ "Confirm change" = "Valider les modifications", "Are you sure to remove user(s): %s from the database ?" = "Etes-vous s\u00fbr de vouloir supprimer %s de la base de donn\u00e9es ?", "Delete user(s)" = "Supprimer l\'/les utilisateur(s)", + "Delete user" = "Supprimer l\'utilisateur", "Edit user" = "Modifier l\'utilisateur", "User already exist!" = "L\'utilisateur existe d\u00e9j\u00e0", "Dismiss" = "Fermer", @@ -114,12 +116,13 @@ "Download logs database" = "T\u00e9l\u00e9charger les logs", "Download SQL database" = "T\u00e9l\u00e9charger la base SQL", "Reset password for %s?" = "R\u00e9initialiser le mot de passe de %s ?", + "Reset password" = "R\u00e9initialiser le mot de passe", "Temporary password:" = "Mot de passe temporaire", "Password succesfully reset!" = "Mot de passe r\u00e9initialis\u00e9", "You are not authorized for this application" = "Vous n\'\u00eates pas habilit\u00e9 pour cette application" ) -.label_ptbr = list( +pkgEnv$label_ptbr = list( "Please authenticate" = "Autentica\u00e7\u00e3o", "Username:" = "Usu\u00e1rio:", "Password:" = "Senha:", @@ -144,6 +147,7 @@ "Confirm change" = "Confirmar mudan\u00e7a", "Are you sure to remove user(s): %s from the database ?" = "Tem certeza que deseja remover o(s) usu\u00e1rio(s) %s do banco de dados?", "Delete user(s)" = "Deletar usu\u00e1rio(s)", + "Delete user" = "Deletar usu\u00e1rio", "Edit user" = "Modificar usu\u00e1rio", "User already exist!" = "O usu\u00e1rio j\u00e1 existe!", "Dismiss" = "Fechar", @@ -173,6 +177,7 @@ "Download logs database" = "Fazer download dos logs do banco de dados", "Download SQL database" = "Fazer download do banco de dados SQL", "Reset password for %s?" = "Resetar a senha de %s?", + "Reset password" = "Resetar a senha", "Temporary password:" = "Senha tempor\u00e1ria", "Password succesfully reset!" = "Senha resetada com sucesso!", "You are not authorized for this application" = "Voc\u00ea n\u00e3o est\u00e1 autorizado a utilizar esse aplicativo" @@ -184,18 +189,6 @@ language <- R6::R6Class( classname = "language", public = list( initialize = function() { - .globals$language <- self - invisible(self) - }, - add = function(...) { - args <- list(...) - if (!all(nzchar(names(args)))) { - stop("All arguments must be named!", call. = FALSE) - } - private$labels <- modifyList( - x = private$labels, - val = lapply(args, I) - ) invisible(self) }, set_language = function(lan) { @@ -203,13 +196,11 @@ language <- R6::R6Class( stop("Unsupported language !", call. = FALSE) } private$language <- lan - as_is <- vapply( - X = private$labels, - FUN = inherits, "AsIs", - FUN.VALUE = logical(1), - USE.NAMES = FALSE + private$labels <- switch (lan, + "en" = pkgEnv$label_en, + "fr" = pkgEnv$label_fr, + "pt-BR" = pkgEnv$label_ptbr ) - private$labels[!as_is] <- private$labels_lan[[lan]][!as_is] }, get = function(label) { private$labels[[label]] @@ -230,12 +221,7 @@ language <- R6::R6Class( private = list( language = "en", language_registered = c("en", "fr", "pt-BR"), - labels = .label_en, - labels_lan = list( - en = .label_en, - fr = .label_fr, - `pt-BR` = .label_ptbr - ), + labels = pkgEnv$label_en, DT_lan = list( fr = list( sProcessing = "Traitement en cours...", sSearch = "Rechercher :", @@ -307,24 +293,18 @@ language <- R6::R6Class( ) - -use_language <- function() { - if (is.null(.globals$language)) - .globals$language <- language$new() - .globals$language +use_language <- function(lan = "en") { + lang <- language$new() + lang$set_language(lan) + lang } -set_language <- function(lan) { - lan_set <- use_language() - lan_set$set_language(lan) -} - - #' @title Modify {shinymanager} labels to use custom text #' #' @description See all labels registered with \code{get_labels()}, #' then set custom text with \code{set_labels()}. #' +#' @param language Language to use for labels, supported values are : "en", "fr", "pt-BR". #' @param ... A named list with labels to replace. #' #' @return \code{get_labels()} return a named list with all labels registered. @@ -336,21 +316,56 @@ set_language <- function(lan) { #' #' # In global.R for example: #' set_labels( +#' language = "en", #' "Please authenticate" = "You have to login", #' "Username:" = "What's your name:", #' "Password:" = "Enter your password:" #' ) -set_labels <- function(...) { - lang <- use_language() - lang$add(...) +set_labels <- function(language, ...) { + if (!language %in% c("en", "fr", "pt-BR")) { + stop("Only supported language for the now are: en, fr, pt-BR", call. = FALSE) + } + args <- list(...) + if (!all(nzchar(names(args)))) { + stop("All arguments must be named!", call. = FALSE) + } + + current_labels <- switch (language, + "en" = pkgEnv$label_en, + "fr" = pkgEnv$label_fr, + "pt-BR" = pkgEnv$label_ptbr + ) + + udpate_labels <- modifyList( + x = current_labels, + val = lapply(args, I) + ) + + if(language %in% "en"){ + pkgEnv$label_en <- udpate_labels + } else if(language %in% "fr"){ + pkgEnv$label_fr <- udpate_labels + } else if(language %in% "pt-BR"){ + pkgEnv$label_ptbr <- udpate_labels + } + + invisible(TRUE) } #' @export #' #' @rdname custom-labels -get_labels <- function() { - lang <- use_language() - lang$get_all() +get_labels <- function(language = "en") { + if (!language %in% c("en", "fr", "pt-BR")) { + warning("Only supported language for the now are: en, fr, pt-BR", call. = FALSE) + language <- "en" + } + + switch (language, + "en" = pkgEnv$label_en, + "fr" = pkgEnv$label_fr, + "pt-BR" = pkgEnv$label_ptbr + ) } diff --git a/R/module-admin.R b/R/module-admin.R index b3af653..12d7f38 100644 --- a/R/module-admin.R +++ b/R/module-admin.R @@ -3,11 +3,13 @@ #' @importFrom DT DTOutput #' @importFrom htmltools tags singleton tagList #' @importFrom shiny NS fluidRow column actionButton icon -admin_ui <- function(id) { +admin_ui <- function(id, lan = NULL) { ns <- NS(id) - lan <- use_language() + if(is.null(lan)){ + lan <- use_language() + } tagList( singleton(tags$head( @@ -94,25 +96,26 @@ admin_ui <- function(id) { } #' @importFrom DT renderDT datatable JS -#' @importFrom shiny reactive observeEvent isolate showModal modalDialog +#' @importFrom shiny reactive observeEvent isolate showModal modalDialog reactiveFileReader #' removeUI insertUI reactiveValues showNotification callModule req updateCheckboxInput #' @importFrom DBI dbConnect #' @importFrom RSQLite SQLite -admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = NULL) { +admin <- function(input, output, session, sqlite_path, passphrase, lan, + inputs_list = NULL) { ns <- session$ns jns <- function(x) { paste0("#", ns(x)) } - - lan <- use_language() - + token_start <- isolate(getToken(session = session)) update_read_db <- reactiveValues(x = NULL) # read users table from database - users <- reactive({ + users <- reactiveVal(NULL) + + observe({ unbindDT(ns("table_users")) update_read_db$x db <- try({ @@ -122,14 +125,22 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = }, silent = TRUE) if (inherits(db, "try-error")) { showModal(modalDialog("An error occurs when connecting or reading the database.")) - return(NULL) + users(NULL) } else { - return(db) + users(db) } }) + # prevent bug having multiple admin session + users_update <- reactiveFileReader(1000, session, sqlite_path, filelReaderDB, passphrase = passphrase, name = "credentials") + observe({ + if(!is.null(users_update())) users(users_update()) + }) + # read password management table from database - pwds <- reactive({ + pwds <- reactiveVal(NULL) + + observe({ unbindDT(ns("table_pwds")) update_read_db$x db <- try({ @@ -139,20 +150,25 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = }, silent = TRUE) if (inherits(db, "try-error")) { showModal(modalDialog("An error occurs when connecting or reading the database.")) - return(NULL) + pwds(NULL) } else { - return(db) + pwds(db) } }) + # prevent bug having multiple admin session + pwds_update <- reactiveFileReader(1000, session, sqlite_path, filelReaderDB, passphrase = passphrase, name = "pwd_mngt") + observe({ + if(!is.null(pwds_update())) pwds(pwds_update()) + }) # displaying users table output$table_users <- renderDT({ req(users()) users <- users() users <- users[, setdiff(names(users), "password"), drop = FALSE] - users$Edit <- input_btns(ns("edit_user"), users$user, "Edit user", icon("pencil-square-o"), status = "primary") - users$Remove <- input_btns(ns("remove_user"), users$user, "Delete user", icon("trash-o"), status = "danger") + users$Edit <- input_btns(ns("edit_user"), users$user, "Edit user", icon("pencil-square-o"), status = "primary", lan = lan()) + users$Remove <- input_btns(ns("remove_user"), users$user, "Delete user", icon("trash-o"), status = "danger", lan = lan()) users$Select <- input_checkbox_ui(ns("remove_mult_users"), users$user) datatable( data = users, @@ -161,7 +177,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = escape = FALSE, selection = "none", options = list( - language = lan$get_DT(), + language = lan()$get_DT(), drawCallback = JS("function() {Shiny.bindAll(this.api().table().node());}"), # initComplete = JS( # "function(settings, json) {", @@ -190,8 +206,8 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = output$table_pwds <- renderDT({ req(pwds()) pwds <- pwds() - pwds$`Change password` <- input_btns(ns("change_pwd"), pwds$user, "Ask to change password", icon("key"), status = "primary") - pwds$`Reset password` <- input_btns(ns("reset_pwd"), pwds$user, "Reset password", icon("undo"), status = "warning") + pwds$`Change password` <- input_btns(ns("change_pwd"), pwds$user, "Ask to change password", icon("key"), status = "primary", lan = lan()) + pwds$`Reset password` <- input_btns(ns("reset_pwd"), pwds$user, "Reset password", icon("undo"), status = "warning", lan = lan()) pwds$Select <- input_checkbox_ui(ns("change_mult_pwds"), pwds$user) datatable( data = pwds, @@ -200,7 +216,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = escape = FALSE, selection = "none", options = list( - language = lan$get_DT(), + language = lan()$get_DT(), drawCallback = JS("function() {Shiny.bindAll(this.api().table().node());}"), # initComplete = JS( # "function(settings, json) {", @@ -236,7 +252,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = }) observeEvent(input$remove_selected_users, { - remove_modal(ns("delete_selected_users"), r_selected_users()) + remove_modal(ns("delete_selected_users"), r_selected_users(), lan()) }) observeEvent(input$delete_selected_users, { @@ -265,15 +281,15 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = }) observeEvent(input$change_selected_pwds, { - change_pwd_modal(ns("changed_password_users"), r_selected_pwds()) + change_pwd_modal(ns("changed_password_users"), r_selected_pwds(), lan()) }) observeEvent(input$changed_password_users, { res_chg <- try(force_chg_pwd(r_selected_pwds()), silent = TRUE) if (inherits(res_chg, "try-error")) { - showNotification(ui = lan$get("Failed to update the database"), type = "error") + showNotification(ui = lan()$get("Failed to update the database"), type = "error") } else { - showNotification(ui = lan$get("Change saved!"), type = "message") + showNotification(ui = lan()$get("Change saved!"), type = "message") update_read_db$x <- Sys.time() } }) @@ -286,13 +302,13 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = users <- users() showModal(modalDialog( title = "Edit user", - edit_user_ui(ns("edit_user"), credentials = users, username = input$edit_user, inputs_list = inputs_list), + edit_user_ui(ns("edit_user"), credentials = users, username = input$edit_user, inputs_list = inputs_list, lan = lan()), tags$div(id = ns("placeholder-edituser-exist")), footer = tagList( - modalButton(lan$get("Cancel")), + modalButton(lan()$get("Cancel")), actionButton( inputId = ns("edited_user"), - label = lan$get("Confirm change"), + label = lan()$get("Confirm change"), class = "btn-primary", `data-dismiss` = "modal" ) @@ -315,7 +331,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = id = ns("alert-edituser-exist"), class = "alert alert-warning", icon("exclamation-triangle"), - lan$get("User already exist!") + lan()$get("User already exist!") ), immediate = TRUE ) @@ -339,9 +355,9 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = write_db_encrypt(conn = conn, value = users, name = "credentials", passphrase = passphrase) }, silent = FALSE) if (inherits(res_edit, "try-error")) { - showNotification(ui = lan$get("Fail to update user"), type = "error") + showNotification(ui = lan()$get("Fail to update user"), type = "error") } else { - showNotification(ui = lan$get("User successfully updated"), type = "message") + showNotification(ui = lan()$get("User successfully updated"), type = "message") update_read_db$x <- Sys.time() } }) @@ -351,14 +367,14 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = observeEvent(input$add_user, { users <- users() showModal(modalDialog( - title = "Add user", - edit_user_ui(ns("add_user"), users, NULL, inputs_list = inputs_list), + title = lan()$get("Add a user"), + edit_user_ui(ns("add_user"), users, NULL, inputs_list = inputs_list, lan = lan()), tags$div(id = ns("placeholder-user-exist")), footer = tagList( - modalButton(lan$get("Cancel")), + modalButton(lan()$get("Cancel")), actionButton( inputId = ns("added_user"), - label = lan$get("Confirm new user"), + label = lan()$get("Confirm new user"), class = "btn-primary", `data-dismiss` = "modal" ) @@ -381,7 +397,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = id = ns("alert-user-exist"), class = "alert alert-warning", icon("exclamation-triangle"), - lan$get("User already exist!") + lan()$get("User already exist!") ), immediate = TRUE ) @@ -424,14 +440,14 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = write_db_encrypt(conn = conn, value = resetpwd, name = "pwd_mngt", passphrase = passphrase) }, silent = FALSE) if (inherits(res_add, "try-error")) { - showNotification(ui = lan$get("Failed to update user"), type = "error") + showNotification(ui = lan()$get("Failed to update user"), type = "error") } else { showModal(modalDialog( tags$p(HTML( - sprintf(lan$get("New user %s succesfully created!"), tags$b(newuser$user)) + sprintf(lan()$get("New user %s succesfully created!"), tags$b(newuser$user)) )), - tags$p(lan$get("Password:"), tags$b(newuser$password)), - footer = modalButton(lan$get("Dismiss")) + tags$p(lan()$get("Password:"), tags$b(newuser$password)), + footer = modalButton(lan()$get("Dismiss")) )) update_read_db$x <- Sys.time() } @@ -440,16 +456,16 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = # launch modal to force a user to change password observeEvent(input$change_pwd, { - change_pwd_modal(ns("changed_password"), input$change_pwd) + change_pwd_modal(ns("changed_password"), input$change_pwd, lan()) }) # store in database that the user must change password on next connection observeEvent(input$changed_password, { res_chg <- try(force_chg_pwd(input$change_pwd), silent = TRUE) if (inherits(res_chg, "try-error")) { - showNotification(ui = lan$get("Failed to update the database"), type = "error") + showNotification(ui = lan()$get("Failed to update the database"), type = "error") } else { - showNotification(ui = lan$get("Change saved!"), type = "message") + showNotification(ui = lan()$get("Change saved!"), type = "message") update_read_db$x <- Sys.time() } }) @@ -457,7 +473,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = # launch modal to reset password observeEvent(input$reset_pwd, { - reset_pwd_modal(ns("reseted_password"), input$reset_pwd) + reset_pwd_modal(ns("reseted_password"), input$reset_pwd, lan()) }) observeEvent(input$reseted_password, { password <- generate_pwd() @@ -469,12 +485,12 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = write_db_encrypt(conn = sqlite_path, value = users, name = "credentials", passphrase = passphrase) res_chg <- try(force_chg_pwd(input$reset_pwd), silent = TRUE) if (inherits(res_chg, "try-error")) { - showNotification(ui = lan$get("Failed to update user"), type = "error") + showNotification(ui = lan()$get("Failed to update user"), type = "error") } else { showModal(modalDialog( - tags$p(lan$get("Password succesfully reset!")), - tags$p(lan$get("Temporary password:"), tags$b(password)), - footer = modalButton(lan$get("Dismiss")) + tags$p(lan()$get("Password succesfully reset!")), + tags$p(lan()$get("Temporary password:"), tags$b(password)), + footer = modalButton(lan()$get("Dismiss")) )) update_read_db$x <- Sys.time() } @@ -486,12 +502,12 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = current_user <- .tok$get_user(token_start) if (identical(current_user, input$remove_user)) { showModal(modalDialog( - lan$get("You can't remove yourself!"), - footer = modalButton(lan$get("Cancel")), + lan()$get("You can't remove yourself!"), + footer = modalButton(lan()$get("Cancel")), easyClose = TRUE )) } else { - remove_modal(ns("delete_user"), input$remove_user) + remove_modal(ns("delete_user"), input$remove_user, lan()) } }) @@ -522,8 +538,7 @@ admin <- function(input, output, session, sqlite_path, passphrase, inputs_list = #' @importFrom htmltools HTML tags tagList #' @importFrom shiny showModal modalDialog modalButton actionButton -remove_modal <- function(inputId, user) { - lan <- use_language() +remove_modal <- function(inputId, user, lan) { showModal(modalDialog( tags$p(HTML(sprintf( lan$get("Are you sure to remove user(s): %s from the database ?"), tags$b(paste(user, collapse = ", ")) @@ -541,10 +556,9 @@ remove_modal <- function(inputId, user) { )) } -change_pwd_modal <- function(inputId, user) { - lan <- use_language() +change_pwd_modal <- function(inputId, user, lan) { showModal(modalDialog( - title = "Change password", + title = lan$get("Ask to change password"), tags$p(HTML( sprintf(lan$get("Ask %s to change password on next connection?"), tags$b(paste(user, collapse = ", "))) )), @@ -560,10 +574,9 @@ change_pwd_modal <- function(inputId, user) { )) } -reset_pwd_modal <- function(inputId, user) { - lan <- use_language() +reset_pwd_modal <- function(inputId, user, lan) { showModal(modalDialog( - title = "Reset password", + title = lan$get("Reset password"), tags$p(HTML( sprintf(lan$get("Reset password for %s?"), tags$b(paste(user, collapse = ", "))) )), diff --git a/R/module-auth.R b/R/module-auth.R index 8a82917..4d07c4f 100644 --- a/R/module-auth.R +++ b/R/module-auth.R @@ -23,11 +23,13 @@ #' @example examples/module-auth.R auth_ui <- function(id, status = "primary", tags_top = NULL, tags_bottom = NULL, background = NULL, - choose_language = NULL, ...) { + choose_language = NULL, lan = NULL, ...) { ns <- NS(id) - lan <- use_language() + if(is.null(lan)){ + lan <- use_language() + } # patch / message changing tag_img & tag_div deprecated <- list(...) @@ -129,7 +131,8 @@ auth_ui <- function(id, status = "primary", tags_top = NULL, #' Must return \code{TRUE} or \code{FALSE}. #' To use additionnals arguments, set them with \code{purrr::partial} (see examples). #' @param use_token Add a token in the URL to check authentication. Should not be used directly. -#' +#' @param lan An langauge object. Should not be used directly. +#' #' @export #' #' @rdname module-authentication @@ -142,15 +145,24 @@ auth_ui <- function(id, status = "primary", tags_top = NULL, #' } #' #' @importFrom htmltools tags -#' @importFrom shiny reactiveValues observeEvent removeUI updateQueryString insertUI icon updateActionButton updateTextInput renderUI +#' @importFrom shiny reactiveValues observeEvent removeUI updateQueryString insertUI is.reactive icon updateActionButton updateTextInput renderUI #' @importFrom stats setNames -auth_server <- function(input, output, session, check_credentials, use_token = FALSE) { +auth_server <- function(input, output, session, check_credentials, + use_token = FALSE, lan = NULL) { ns <- session$ns jns <- function(x) { paste0("#", ns(x)) } + if(!is.reactive(lan)){ + if(is.null(lan)){ + lan <- reactive(use_language()) + } else { + lan <- reactive(lan) + } + } + observe({ session$sendCustomMessage( type = "focus_input", @@ -158,25 +170,23 @@ auth_server <- function(input, output, session, check_credentials, use_token = F ) }) - lan <- use_language() - observe({ if(!is.null(input$language)){ - lan$set_language(input$language) - updateTextInput(session, inputId = "user_id", label = lan$get("Username:")) - updateTextInput(session, inputId = "user_pwd", label = lan$get("Password:")) - updateActionButton(session, inputId = "go_auth", label = lan$get("Login")) + lan()$set_language(input$language) + updateTextInput(session, inputId = "user_id", label = lan()$get("Username:")) + updateTextInput(session, inputId = "user_pwd", label = lan()$get("Password:")) + updateActionButton(session, inputId = "go_auth", label = lan()$get("Login")) session$sendCustomMessage( type = "update_auth_title", message = list( inputId = ns("shinymanager-auth-head"), - title = lan$get("Please authenticate") + title = lan()$get("Please authenticate") ) ) output$update_shinymanager_language <- renderUI({ - shinymanager_language(lan$get_language()) + shinymanager_language(lan()$get_language()) }) } }) @@ -197,7 +207,7 @@ auth_server <- function(input, output, session, check_credentials, use_token = F if (isTRUE(use_token)) { # add_token(token, as.list(res_auth$user_info)) .tok$add(token, as.list(res_auth$user_info)) - updateQueryString(queryString = paste0("?token=", token), session = session) + updateQueryString(queryString = paste0("?token=", token, "&language=", lan()$get_language()), session = session) session$reload() } @@ -208,7 +218,7 @@ auth_server <- function(input, output, session, check_credentials, use_token = F selector = jns("result_auth"), ui = tags$div( id = ns("msg_auth"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("Username or password are incorrect") + icon("exclamation-triangle"), lan()$get("Username or password are incorrect") ) ) } else if (isTRUE(res_auth$expired)) { @@ -217,7 +227,7 @@ auth_server <- function(input, output, session, check_credentials, use_token = F selector = jns("result_auth"), ui = tags$div( id = ns("msg_auth"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("Your account has expired") + icon("exclamation-triangle"), lan()$get("Your account has expired") ) ) } else { @@ -227,7 +237,7 @@ auth_server <- function(input, output, session, check_credentials, use_token = F selector = jns("result_auth"), ui = tags$div( id = ns("msg_auth"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("You are not authorized for this application") + icon("exclamation-triangle"), lan()$get("You are not authorized for this application") ) ) } else { @@ -236,7 +246,7 @@ auth_server <- function(input, output, session, check_credentials, use_token = F selector = jns("result_auth"), ui = tags$div( id = ns("msg_auth"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("Username or password are incorrect") + icon("exclamation-triangle"), lan()$get("Username or password are incorrect") ) ) } diff --git a/R/module-edit_user.R b/R/module-edit_user.R index 8d33d32..dc4e1d7 100644 --- a/R/module-edit_user.R +++ b/R/module-edit_user.R @@ -2,11 +2,13 @@ #' @importFrom shiny NS dateInput checkboxInput textInput #' @importFrom htmltools tagList #' @importFrom R.utils capitalize -edit_user_ui <- function(id, credentials, username = NULL, inputs_list = NULL) { +edit_user_ui <- function(id, credentials, username = NULL, inputs_list = NULL, lan = NULL) { ns <- NS(id) - lan <- use_language() + if(is.null(lan)){ + lan <- use_language() + } if (!is.null(username) && username %in% credentials$user) { data_user <- credentials[credentials$user == username, ] diff --git a/R/module-pwd.R b/R/module-pwd.R index c098334..7efc663 100644 --- a/R/module-pwd.R +++ b/R/module-pwd.R @@ -15,11 +15,13 @@ #' @importFrom shiny NS fluidRow column passwordInput actionButton #' #' @example examples/module-pwd.R -pwd_ui <- function(id, tag_img = NULL, status = "primary") { +pwd_ui <- function(id, tag_img = NULL, status = "primary", lan = NULL) { ns <- NS(id) - lan <- use_language() + if(is.null(lan)){ + lan <- use_language() + } tagList( singleton(tags$head( @@ -91,7 +93,8 @@ pwd_ui <- function(id, tag_img = NULL, status = "primary") { #' Default is to check for the password to have at least one number, one lowercase, #' one uppercase and be of length 6 at least. #' @param use_token Add a token in the URL to check authentication. Should not be used directly. -#' +#' @param lan An langauge object. Should not be used directly. +#' #' @export #' #' @rdname module-password @@ -99,8 +102,17 @@ pwd_ui <- function(id, tag_img = NULL, status = "primary") { #' @importFrom htmltools tags #' @importFrom shiny reactiveValues observeEvent removeUI insertUI icon actionButton #' @importFrom utils getFromNamespace -pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = NULL, use_token = FALSE) { +pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = NULL, + use_token = FALSE, lan = NULL) { + if(!is.reactive(lan)){ + if(is.null(lan)){ + lan <- reactive(use_language()) + } else { + lan <- reactive(lan) + } + } + if (is.null(validate_pwd)) { validate_pwd <- getFromNamespace("validate_pwd", "shinymanager") } @@ -112,8 +124,6 @@ pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = password <- reactiveValues(result = FALSE, user = NULL, relog = NULL) - lan <- use_language() - observeEvent(input$update_pwd, { password$relog <- NULL removeUI(selector = jns("msg_pwd")) @@ -122,7 +132,7 @@ pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = selector = jns("result_pwd"), ui = tags$div( id = ns("msg_pwd"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("The two passwords are different") + icon("exclamation-triangle"), lan()$get("The two passwords are different") ) ) } else { @@ -131,7 +141,7 @@ pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = selector = jns("result_pwd"), ui = tags$div( id = ns("msg_pwd"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("Password does not respect safety requirements") + icon("exclamation-triangle"), lan()$get("Password does not respect safety requirements") ) ) } else { @@ -146,11 +156,11 @@ pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = id = ns("msg_pwd"), tags$div( class = "alert alert-success", - icon("check"), lan$get("Password successfully updated! Please re-login") + icon("check"), lan()$get("Password successfully updated! Please re-login") ), actionButton( inputId = ns("relog"), - label = lan$get("Login"), + label = lan()$get("Login"), width = "100%" ) ) @@ -160,7 +170,7 @@ pwd_server <- function(input, output, session, user, update_pwd, validate_pwd = selector = jns("result_pwd"), ui = tags$div( id = ns("msg_pwd"), class = "alert alert-danger", - icon("exclamation-triangle"), lan$get("Failed to update password") + icon("exclamation-triangle"), lan()$get("Failed to update password") ) ) } diff --git a/R/modules-logs.R b/R/modules-logs.R index 3c6304c..6dacfb2 100644 --- a/R/modules-logs.R +++ b/R/modules-logs.R @@ -3,11 +3,13 @@ #' @importFrom billboarder billboarderOutput #' @importFrom shiny NS fluidRow column icon selectInput dateRangeInput downloadButton downloadHandler conditionalPanel #' @importFrom htmltools tagList tags -logs_ui <- function(id) { +logs_ui <- function(id, lan = NULL) { ns <- NS(id) - lan <- use_language() + if(is.null(lan)){ + lan <- use_language() + } tagList( fluidRow( @@ -102,15 +104,14 @@ logs_ui <- function(id) { #' bb_x_axis bb_zoom %>% bb_bar_color_manual #' @importFrom shiny reactiveValues observe req updateSelectInput updateDateRangeInput reactiveVal outputOptions #' @importFrom utils write.table -logs <- function(input, output, session, sqlite_path, passphrase, fileEncoding = "") { +logs <- function(input, output, session, sqlite_path, passphrase, + fileEncoding = "", lan = NULL) { ns <- session$ns jns <- function(x) { paste0("#", ns(x)) } - lan <- use_language() - logs_rv <- reactiveValues(logs = NULL, logs_period = NULL, users = NULL) print_app_input <- reactiveVal(FALSE) @@ -184,7 +185,7 @@ logs <- function(input, output, session, sqlite_path, passphrase, fileEncoding = bb_x_axis(tick = list(width = 10000)) %>% bb_labs( # title = "Number of connection by user", - y = lan$get("Total number of connection") + y = lan()$get("Total number of connection") ) %>% bb_zoom( enabled = list(type = "drag"), @@ -221,7 +222,7 @@ logs <- function(input, output, session, sqlite_path, passphrase, fileEncoding = bb_legend(show = FALSE) %>% bb_labs( # title = "Number of connection by user", - y = lan$get("Total number of connection") + y = lan()$get("Total number of connection") ) %>% # bb_bar(width = list(ratio = 1, max = 30)) %>% bb_zoom( diff --git a/R/secure-app.R b/R/secure-app.R index 6777d49..1ed931e 100644 --- a/R/secure-app.R +++ b/R/secure-app.R @@ -30,8 +30,8 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = warning("Only supported language for the now are: en, fr, pt-BR", call. = FALSE) language <- "en" } - set_language(language) - lan <- use_language() + + lan <- use_language(language) ui <- force(ui) enable_admin <- force(enable_admin) head_auth <- force(head_auth) @@ -43,12 +43,16 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = query <- parseQueryString(request$QUERY_STRING) token <- query$token admin <- query$admin - # browser() + language <- query$language + if(!is.null(language)){ + lan <- use_language(language) + } if (.tok$is_valid(token)) { is_forced_chg_pwd <- is_force_chg_pwd(token = token) if (is_forced_chg_pwd) { args <- get_args(..., fun = pwd_ui) args$id <- "password" + args$lan <- lan pwd_ui <- fluidPage( theme = theme, tags$head(head_auth), @@ -77,18 +81,19 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = tooltip = lan$get("Go to application"), icon = icon("share") ) - ) + ), + shinymanager_where("admin") ), tabPanel( title = tagList(icon("home"), lan$get("Home")), value = "home", - admin_ui("admin"), - shinymanager_where("admin"), + admin_ui("admin", lan), shinymanager_language(lan$get_language()) ), tabPanel( title = "Logs", - logs_ui("logs") + logs_ui("logs", lan), + shinymanager_language(lan$get_language()) ) ) } else { @@ -125,7 +130,8 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = ui <- ui(request) } tagList( - ui, menu, shinymanager_where("application"), shinymanager_language(lan$get_language()), + ui, menu, shinymanager_where("application"), + shinymanager_language(lan$get_language()), singleton(tags$head(tags$script(src = "shinymanager/timeout.js"))) ) } @@ -142,11 +148,13 @@ secure_app <- function(ui, ..., enable_admin = FALSE, head_auth = NULL, theme = warning("'tag_div' (auth_ui, secure_app) is now deprecated. Please use 'tags_bottom'", call. = FALSE) } args$id <- "auth" + args$lan <- lan fluidPage( theme = theme, tags$head(head_auth), do.call(auth_ui, args), - shinymanager_where("authentication") + shinymanager_where("authentication"), + shinymanager_language(lan$get_language()) ) } } @@ -191,11 +199,20 @@ secure_server <- function(check_credentials, timeout = 15, inputs_list = NULL, isolate(resetQueryString(session = session)) token_start <- isolate(getToken(session = session)) + lan <- reactiveVal(use_language()) + observe({ + lang <- getLanguage(session = session) + if(!is.null(lang)) { + lan(use_language(lang)) + } + }) + callModule( module = auth_server, id = "auth", check_credentials = check_credentials, - use_token = TRUE + use_token = TRUE, + lan = lan ) callModule( @@ -203,7 +220,8 @@ secure_server <- function(check_credentials, timeout = 15, inputs_list = NULL, id = "password", user = reactiveValues(user = .tok$get(token_start)$user), update_pwd = update_pwd, - use_token = TRUE + use_token = TRUE, + lan = lan ) .tok$set_timeout(timeout) @@ -215,14 +233,16 @@ secure_server <- function(check_credentials, timeout = 15, inputs_list = NULL, id = "admin", sqlite_path = path_sqlite, passphrase = .tok$get_passphrase(), - inputs_list = inputs_list + inputs_list = inputs_list, + lan = lan ) callModule( module = logs, id = "logs", sqlite_path = path_sqlite, passphrase = .tok$get_passphrase(), - fileEncoding = fileEncoding + fileEncoding = fileEncoding, + lan = lan ) } @@ -250,14 +270,14 @@ secure_server <- function(check_credentials, timeout = 15, inputs_list = NULL, observeEvent(session$input$.shinymanager_admin, { token <- getToken(session = session) - updateQueryString(queryString = sprintf("?token=%s&admin=true", token), session = session, mode = "replace") + updateQueryString(queryString = sprintf("?token=%s&admin=true&language=%s", token, lan()$get_language()), session = session, mode = "replace") .tok$reset_count(token) session$reload() }, ignoreInit = TRUE) observeEvent(session$input$.shinymanager_app, { token <- getToken(session = session) - updateQueryString(queryString = sprintf("?token=%s", token), session = session, mode = "replace") + updateQueryString(queryString = sprintf("?token=%s&language=%s", token, lan()$get_language()), session = session, mode = "replace") .tok$reset_count(token) session$reload() }, ignoreInit = TRUE) diff --git a/R/shiny-utils.R b/R/shiny-utils.R index 0e77565..880d62f 100644 --- a/R/shiny-utils.R +++ b/R/shiny-utils.R @@ -24,7 +24,7 @@ shinymanager_where <- function(where) { tags$div( style = "display: none;", selectInput(inputId = "shinymanager_where", label = NULL, - choices = where, selected = where, multiple = TRUE) + choices = where, selected = where, multiple = FALSE) ) } @@ -32,7 +32,7 @@ shinymanager_language <- function(lan) { tags$div( style = "display: none;", selectInput(inputId = "shinymanager_language", label = NULL, - choices = lan, selected = lan, multiple = TRUE) + choices = lan, selected = lan, multiple = FALSE) ) } @@ -50,11 +50,19 @@ getToken <- function(session = getDefaultReactiveDomain()) { query$token } +# Retrieve language from the query string +#' @importFrom shiny getQueryString getDefaultReactiveDomain +getLanguage <- function(session = getDefaultReactiveDomain()) { + query <- getQueryString(session = session) + query$language +} + # Remove the token from the query string #' @importFrom shiny updateQueryString getQueryString getDefaultReactiveDomain resetQueryString <- function(session = getDefaultReactiveDomain()) { query <- getQueryString(session = session) query$token <- NULL + query$language <- NULL if (length(query) == 0) { clearQueryString(session = session) } else { @@ -67,8 +75,12 @@ resetQueryString <- function(session = getDefaultReactiveDomain()) { #' @importFrom htmltools tags doRenderTags #' @importFrom shiny icon -input_btns <- function(inputId, users, tooltip, icon, status = "primary") { - lan <- use_language() +input_btns <- function(inputId, users, tooltip, icon, status = "primary", lan = NULL) { + + if(is.null(lan)){ + lan <- use_language() + } + tag <- lapply( X = users, FUN = function(x) { @@ -123,3 +135,10 @@ unbindDT <- function(id, session = getDefaultReactiveDomain()) { message = list(id = id) ) } + +filelReaderDB <- function(sqlite_path, passphrase, name){ + conn <- dbConnect(SQLite(), dbname = sqlite_path) + on.exit(dbDisconnect(conn)) + tryCatch(read_db_decrypt(conn = conn, name = name, passphrase = passphrase), + error = function(e) NULL) +} diff --git a/examples/demo/global.R b/examples/demo/global.R index 77a7327..a4c2efd 100644 --- a/examples/demo/global.R +++ b/examples/demo/global.R @@ -24,3 +24,9 @@ credentials <- data.frame( # passphrase = "supersecret" # ) +set_labels( + language = "en", + "Please authenticate" = "You have to login", + "Username:" = "What's your name:", + "Password:" = "Enter your password:" +) diff --git a/man/custom-labels.Rd b/man/custom-labels.Rd index fbcaeb6..b30522a 100644 --- a/man/custom-labels.Rd +++ b/man/custom-labels.Rd @@ -6,11 +6,13 @@ \alias{get_labels} \title{Modify {shinymanager} labels to use custom text} \usage{ -set_labels(...) +set_labels(language, ...) -get_labels() +get_labels(language = "en") } \arguments{ +\item{language}{Language to use for labels, supported values are : "en", "fr", "pt-BR".} + \item{...}{A named list with labels to replace.} } \value{ @@ -24,6 +26,7 @@ See all labels registered with \code{get_labels()}, # In global.R for example: set_labels( + language = "en", "Please authenticate" = "You have to login", "Username:" = "What's your name:", "Password:" = "Enter your password:" diff --git a/man/module-authentication.Rd b/man/module-authentication.Rd index 8ae87da..0e2e7a7 100644 --- a/man/module-authentication.Rd +++ b/man/module-authentication.Rd @@ -6,10 +6,25 @@ \alias{auth_server} \title{Authentication module} \usage{ -auth_ui(id, status = "primary", tags_top = NULL, tags_bottom = NULL, - background = NULL, choose_language = NULL, ...) +auth_ui( + id, + status = "primary", + tags_top = NULL, + tags_bottom = NULL, + background = NULL, + choose_language = NULL, + lan = NULL, + ... +) -auth_server(input, output, session, check_credentials, use_token = FALSE) +auth_server( + input, + output, + session, + check_credentials, + use_token = FALSE, + lan = NULL +) } \arguments{ \item{id}{Module's id.} @@ -27,6 +42,8 @@ Valid status are: \code{"default"}, \code{"primary"}, \code{"success"}, \item{choose_language}{\code{logical/character}. Add language selection on top ? TRUE for all supported languages or a vector of possibilities like \code{c("fr", "en")}. If enabled, \code{input$shinymanager_language} is created} +\item{lan}{An langauge object. Should not be used directly.} + \item{...}{: Used for old version compatibility.} \item{input, output, session}{Standard Shiny server arguments.} diff --git a/man/module-password.Rd b/man/module-password.Rd index f5ef22b..6240688 100644 --- a/man/module-password.Rd +++ b/man/module-password.Rd @@ -6,10 +6,18 @@ \alias{pwd_server} \title{New password module} \usage{ -pwd_ui(id, tag_img = NULL, status = "primary") - -pwd_server(input, output, session, user, update_pwd, validate_pwd = NULL, - use_token = FALSE) +pwd_ui(id, tag_img = NULL, status = "primary", lan = NULL) + +pwd_server( + input, + output, + session, + user, + update_pwd, + validate_pwd = NULL, + use_token = FALSE, + lan = NULL +) } \arguments{ \item{id}{Module's id.} @@ -20,6 +28,8 @@ pwd_server(input, output, session, user, update_pwd, validate_pwd = NULL, Valid status are: \code{"default"}, \code{"primary"}, \code{"success"}, \code{"warning"}, \code{"danger"}.} +\item{lan}{An langauge object. Should not be used directly.} + \item{input, output, session}{Standard Shiny server arguments.} \item{user}{A \code{reactiveValues} with a slot \code{user}, diff --git a/man/secure-app.Rd b/man/secure-app.Rd index 8946da3..ee4b631 100644 --- a/man/secure-app.Rd +++ b/man/secure-app.Rd @@ -6,11 +6,22 @@ \alias{secure_server} \title{Secure a Shiny application and manage authentication} \usage{ -secure_app(ui, ..., enable_admin = FALSE, head_auth = NULL, - theme = NULL, language = "en") +secure_app( + ui, + ..., + enable_admin = FALSE, + head_auth = NULL, + theme = NULL, + language = "en" +) -secure_server(check_credentials, timeout = 15, inputs_list = NULL, - fileEncoding = "", session = shiny::getDefaultReactiveDomain()) +secure_server( + check_credentials, + timeout = 15, + inputs_list = NULL, + fileEncoding = "", + session = shiny::getDefaultReactiveDomain() +) } \arguments{ \item{ui}{UI of the application.}