Shiny dashboard, user authentication

Question

I am trying to include a shiny dashboard inside a code snippet I found (https://github.com/treysp/shiny_password) that wraps a shiny app inside functions to set up user authentication.

This snippets works perfectly with fluidPage() but I noticed that it is not working when I wrap a dhasboardPage(): I try to log in, type in my username and my password, click on log in and then nothing happens, I am stuck on the login page. No error message in the console I use to fire up the server by calling runApp()

Do you have any idea of what might cause this particular problem?

Thanks in advance

Answer 1

Here is a working example for you to start. This is a very basic implementation.

1. In the test case the stored passwords are visible. You do not want to authenticate in this way. It is unsafe. You need to find a way to hash the passwords and match. There are some clues on Huidong Tian github link

2. I implemented the majority of the ui.r code in server.r. Not sure if there is a workaround. The drawback I notice is too many lines of code. It will be nice to break each side tab into a separate file. Did not try it myself yet. However, here is @Dean Attali superb shiny resource to split code

ui.r

require(shiny)
require(shinydashboard)

header <- dashboardHeader(title = "my heading")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"))
body <- dashboardBody(uiOutput("body"))
ui <- dashboardPage(header, sidebar, body)

server.r

login_details <- data.frame(user = c("sam", "pam", "ron"),
                            pswd = c("123", "123", "123"))
login <- box(
  title = "Login",
  textInput("userName", "Username"),
  passwordInput("passwd", "Password"),
  br(),
  actionButton("Login", "Log in")
)

server <- function(input, output, session) {
  # To logout back to login page
  login.page = paste(
    isolate(session$clientData$url_protocol),
    "//",
    isolate(session$clientData$url_hostname),
    ":",
    isolate(session$clientData$url_port),
    sep = ""
  )
  histdata <- rnorm(500)
  USER <- reactiveValues(Logged = F)
  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(login_details$user %in% Username)
          Id.password <- which(login_details$pswd %in% Password)
          if (length(Id.username) > 0 & length(Id.password) > 0){
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            }
          }
        }
      }
    }
  })
  output$sidebarpanel <- renderUI({
    if (USER$Logged == TRUE) {
      div(
        sidebarUserPanel(
          isolate(input$userName),
          subtitle = a(icon("usr"), "Logout", href = login.page)
        ),
        selectInput(
          "in_var",
          "myvar",
          multiple = FALSE,
          choices = c("option 1", "option 2")
        ),
        sidebarMenu(
          menuItem(
            "Item 1",
            tabName = "t_item1",
            icon = icon("line-chart")
          ),
          menuItem("Item 2",
                   tabName = "t_item2",
                   icon = icon("dollar"))
        )
      )
    }
  })

  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      tabItems(
        # First tab content
        tabItem(tabName = "t_item1",
                fluidRow(
                  output$plot1 <- renderPlot({
                    data <- histdata[seq_len(input$slider)]
                    hist(data)
                  }, height = 300, width = 300) ,
                  box(
                    title = "Controls",
                    sliderInput("slider", "observations:", 1, 100, 50)
                  )
                )),

        # Second tab content
        tabItem(
          tabName = "t_item2",
          fluidRow(
            output$table1 <- renderDataTable({
              iris
            }),
            box(
              title = "Controls",
              sliderInput("slider", "observations:", 1, 100, 50)
            )
          )
        )
      )
    } else {
      login
    }
  })
}

Answer 2

I recently wrote an R package that provides login/logout modules you can integrate with shinydashboard.

Blogpost with example app

Package repo

the inst/ directory in the package repo contains the code for the example app.

Answer 3

@user5249203's answer is very useful, but as is will produce a (non-breaking) due to the passwords being the same.

Warning in if (Id.username == Id.password) { :
  the condition has length > 1 and only the first element will be used

A better (and simpler) solution may be to replace the 6 lines after:

 Password <- isolate(input$passwd) 

with

 if (nrow(login_details[login_details$user == Username & 
                        login_details$pswd == Password,]) >= 1) {
    USER$Logged <- TRUE
 }