Starting Shiny app after password input

Question

I know that in Shiny Server Pro there is a function of password control. The question is that Shiny has function passwordInput(), which is like textInput() Has anybody thought about how to do the following:

1) Launching the application only after correct password input 2) Launching the part of application after correct password input (for example, I have some tabs in shinydashboard, and I want to make an acces to one of them only by password)

Thanks!

Answer 1

Adding onto the first answer, you can also encrypt your password easily by combining shinymanager with the scrypt package. To do so, you can first generate a password and hash it:

library(scrypt) password <- hashPassword("ice") password #copy this hashed output and then paste it in your app's code 

Now, if we take the earlier example, all you need to do to modify it is make an object that has your hashed value (not the raw) and set the is_hashed_password argument within credentials to TRUE.

You can access the app (user name: 1) without having your raw password stored in the script.

library(shiny) library(shinymanager) library(scrypt)  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();"  password <- "c2NyeXB0ABAAAAAIAAAAAVYhtzTyvRJ9e3hYVOOk63KUzmu7rdoycf3MDQ2jKLDQUkpCpweMU3xCvI3C6suJbKss4jrNBxaEdT/fBzxJitY3vGABhpPahksMpNu/Jou5"  # data.frame with credentials info credentials <- data.frame(   user = c("1", "fanny", "victor", "benoit"),   password = password,   is_hashed_password = TRUE,   # 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) 

Answer 2

EDIT 2019: We can now use the package shinymanager to do this: the invactivity script is to timeout the login page after 2 mins of inactivity so you dont waste resources:

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) 

Original Post: I am going to answer #1 and for #2 you can simply expand on my example. Following this example Encrypt password with md5 for Shiny-app. you can do the following:

1. Create 2 pages and if the user inputs the correct username and password you can renderUI and use htmlOutput to output your page
2. You can style the position of the box with username and password with tagsas I did and color them if you want also using tags$style

You can then further look into the actual page and specify what should be created as a result of different users. You can also look into JavaScript Popup Boxes

EDIT 2018: Also have a look at the example here https://shiny.rstudio.com/gallery/authentication-and-database.html

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))