Запуск приложения Shiny после ввода пароля
Я знаю, что в Shiny Server Pro есть функция управления паролями.
Вопрос в том, что у Shiny есть функция passwordInput(), которая похожа на textInput()
Кто-нибудь думал о том, как сделать следующее:
1) Запуск приложения только после правильного ввода пароля
2) Запуск части приложения после правильного ввода пароля (например, у меня есть несколько вкладок в shinydashboard, и я хочу сделать доступ к одному из них только по паролю)
Спасибо!
Ответы
Ответ 1
ОБНОВЛЕНИЕ 2019: Теперь мы можем использовать пакет shinymanager, чтобы сделать это: скрипт invactivity предназначен для тайм-аута страницы входа в систему после 2 минут бездействия, чтобы вы не теряли ресурсы:
library(shiny)
library(shinymanager)
inactivity <- "function idleTimer() {
var t = setTimeout(logout, 120000);
window.onmousemove = resetTimer; // catches mouse movements
window.onmousedown = resetTimer; // catches mouse movements
window.onclick = resetTimer; // catches mouse clicks
window.onscroll = resetTimer; // catches scrolling
window.onkeypress = resetTimer; //catches keyboard actions
function logout() {
window.close(); //close the window
}
function resetTimer() {
clearTimeout(t);
t = setTimeout(logout, 120000); // time is in milliseconds (1000 is 1 second)
}
}
idleTimer();"
# data.frame with credentials info
credentials <- data.frame(
user = c("1", "fanny", "victor", "benoit"),
password = c("1", "azerty", "12345", "azerty"),
# comment = c("alsace", "auvergne", "bretagne"), %>%
stringsAsFactors = FALSE
)
ui <- secure_app(head_auth = tags$script(inactivity),
fluidPage(
# classic app
headerPanel('Iris k-means clustering'),
sidebarPanel(
selectInput('xcol', 'X Variable', names(iris)),
selectInput('ycol', 'Y Variable', names(iris),
selected=names(iris)[[2]]),
numericInput('clusters', 'Cluster count', 3,
min = 1, max = 9)
),
mainPanel(
plotOutput('plot1'),
verbatimTextOutput("res_auth")
)
))
server <- function(input, output, session) {
result_auth <- secure_server(check_credentials = check_credentials(credentials))
output$res_auth <- renderPrint({
reactiveValuesToList(result_auth)
})
# classic app
selectedData <- reactive({
iris[, c(input$xcol, input$ycol)]
})
clusters <- reactive({
kmeans(selectedData(), input$clusters)
})
output$plot1 <- renderPlot({
palette(c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3",
"#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999"))
par(mar = c(5.1, 4.1, 0, 1))
plot(selectedData(),
col = clusters()$cluster,
pch = 20, cex = 3)
points(clusters()$centers, pch = 4, cex = 4, lwd = 4)
})
}
shinyApp(ui = ui, server = server)
![enter image description here]()
Исходное сообщение:
Я собираюсь ответить # 1, а для № 2 вы можете просто расширить мой пример. Следуя этому примеру, зашифруйте пароль с помощью md5 для Shiny-app. вы можете сделать следующее:
1) Создайте 2 страницы, и если пользователь вводит правильное имя пользователя и пароль, вы можете renderUI и использовать htmlOutput для вывода вашей страницы.
2) Как и я, вы можете назначить положение поля с именем пользователя и паролем с помощью tags и раскрасить их, если хотите, используя tags$style
Затем вы можете дополнительно просмотреть фактическую страницу и указать, что должно быть создано в результате действий разных пользователей. Вы также можете просмотреть всплывающие окна JavaScript
ОБНОВЛЕНИЕ 2018: Также посмотрите на пример здесь https://shiny.rstudio.com/gallery/authentication-and-database.html
![Example of front page]()
rm(list = ls())
library(shiny)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
)}
ui2 <- function(){tagList(tabPanel("Test"))}
ui = (htmlOutput("page"))
server = (function(input, output,session) {
USER <- reactiveValues(Logged = Logged)
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
div(class="outer",do.call(bootstrapPage,c("",ui1())))
})
}
if (USER$Logged == TRUE)
{
output$page <- renderUI({
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
})
print(ui)
}
})
})
runApp(list(ui = ui, server = server))
Ответ 2
Я должен был задать тот же вопрос, наткнулся на приведенный выше ответ и нашел его слишком сложным для реализации. По-видимому, в SO были другие пользователи с подобными проблемами для реализации вышеуказанного решения.
Я построил намного более простой обходной путь, используя добавление/удаление табуляции и блестящий. Вот как это работает. Это может помочь тем, кто не хочет работать с двумя отдельными функциями пользовательского интерфейса.
- Создайте вкладку для входа, в которую пользователи смогут войти. Все остальные вкладки еще не отображаются, а также боковая панель.
- После успешного входа:
Добавьте вкладки, которые вы действительно хотите показать, удалите вкладку входа в систему (она больше не нужна) и покажите боковую панель с блестящей.
Я приведу простой пример ниже. Кроме того, я добавил некоторые функции, которые не являются необходимыми, такие как подсчет истории пользователя и ограничение количества попыток входа в систему, журнал пользователя и обработчик сообщений и т.д. Я прокомментировал эти функции, чтобы упростить задачу, но если вам интересно, взгляните. Обратите внимание, что дополнительные функции должны быть запущены на сервере.
Единственный недостаток неиспользуемого сервера Pro - это отсутствующее соединение https, которое необходимо добавить с помощью другого обходного пути, если это действительно необходимо.
Я задокументировал простой пример и подход с дополнительными функциями на GitHub. Работающую версию последней можно найти на shinyapps.io.
Ниже я публикую код более простой версии приложения, ориентируясь на сам логин.
Имена пользователей и пароли, необходимые для входа в систему, следующие:
username password
user123 loginpassword1
user456 loginpassword2
В реальном приложении они должны храниться в виде хэшей на сервере.
library("shiny")
library("shinyjs")
library("stringr")
# in case you want to send error messages when login is wrong
# add this to the /www folder in your shiny app (shiny server) as message-handler.js file
#
# // This recieves messages of type "testmessage" from the server.
# Shiny.addCustomMessageHandler("testmessage",
# function(message) {
# alert(JSON.stringify(message));
# }
# );
shinyApp(
ui = fluidPage(
useShinyjs(), # Set up shinyjs
# Layout mit Sidebar
sidebarLayout(
## Sidebar -----
shinyjs::hidden(
div(id = "Sidebar", sidebarPanel(
# > some example input on sidebar -----
conditionalPanel(
condition = "input.tabselected > 1",
dateRangeInput(inputId = "date",
label = "Choose date range",
start = "2018-06-25", end = "2019-01-01",
min = "2018-06-25", max = "2019-01-01",
startview = "year"))
))), # closes Sidebar-Panel
# Main-Panel ------
mainPanel(
tabsetPanel(
# > Login -------
tabPanel("Login",
value = 1,
br(),
textInput("username", "Username"),
passwordInput("password", label = "Passwort"),
# If you want to add custom javascript messages
# tags$head(tags$script(src = "message-handler.js")),
actionButton("login", "Login"),
textOutput("pwd")
), # closes tabPanel
id = "tabselected", type = "pills"
) # closes tabsetPanel
) # closes mainPanel
) # closes sidebarLayout
), # closes fluidPage
# Server ------
server = function(input, output, session){
user_vec <- c("user123" = "loginpassword1",
"user456" = "loginpassword2")
# I usually do run the code below on a real app on a server
# user <- reactiveValues(his = readRDS(file = "logs/user_his.rds"),
# log = readRDS(file = "logs/user_log.rds"),
# vec = readRDS(file = "logs/user_vec.rds"))
#
# where user_his is defined as follows
# user_his <- vector(mode = "integer", length = length(user_vec))
# names(user_his) <- names(user_vec)
observeEvent(input$login, {
if (str_to_lower(input$username) %in% names(user_vec)) { # is username in user_vec?
# Alternatively if you want to limit login attempts to "3" using the user_his file
# if (str_to_lower(input$username) %in% names(user$vec[user$his < 3])) {
if (input$password == unname(user_vec[str_to_lower(input$username)])) {
# nulls the user_his login attempts and saves this on server
# user$his[str_to_lower(input$username)] <- 0
# saveRDS(user$his, file = "logs/user_his.rds")
# Saves a temp log file
# user_log_temp <- data.frame(username = str_to_lower(input$username),
# timestamp = Sys.time())
# saves temp log in reactive value
# user$log <- rbind(user$log, user_log_temp)
# saves reactive value on server
# saveRDS(user$log, file = "logs/user_log.rds")
# > Add MainPanel and Sidebar----------
shinyjs::show(id = "Sidebar")
appendTab(inputId = "tabselected",
tabPanel("Tab 1",
value = 2
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 2",
value = 3
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 3",
value = 4
) # closes tabPanel
)
removeTab(inputId = "tabselected",
target = "1")
} else { # username correct, password wrong
# adds a login attempt to user_his
# user$his[str_to_lower(input$username)] <- user$his[str_to_lower(input$username)] + 1
# saves user_his on server
# saveRDS(user$his, file = "logs/user_his.rds")
# Messge which shows how many log-in tries are left
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Password not correct. ',
# 'Remaining log-in tries: ',
# 3 - user$his[str_to_lower(input$username)]
# )
# )
} # closes if-clause
} else { # username name wrong or more than 3 log-in failures
# Send error messages with javascript message handler
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Wrong user name or user blocked.')
# )
} # closes second if-clause
}) # closes observeEvent
} # Closes server
) # Closes ShinyApp
