paulc91 / shinyauthr Goto Github PK

The live example app linked in the README returns a 404 for me.

Hello,

I'm trying to implement the return key that triggers the connect button in a Shiny app. I saw what you did using some js here (https://gist.github.com/PaulC91/bd5035875305dfad504f1a3794233186).
So I tried to connect both methods but unsuccessfully ...

Here is the jQuery code I used :

$(document).keyup(function(event) {
    if ($("#id").is(":focus") && (event.keyCode == 13)) {
        $("#button").click();
    }
});

I think that as the id is namepaces in the loginUI, this method won't work.
Any idea ? :)

Thank you in advance,
Marouane

I have built an app using the following example as a template as it uses shinydashboard and hides content until a user has logged in.
https://github.com/PaulC91/shinyauthr/blob/master/inst/shiny-examples/shinyauthr_example/app.R

I am having trouble showing a loading icon/spinner while plots are build built. For example, using the shinycssloaders package with the 'withSpinner()' function. This should be added as follows: plotOutput("myplot") %>% withSpinner().

However as I am using the uiOutput("testUI") function and renderUI() within the server, its unclear where the withSpinner() function should be added. Ive tried all the options i can think of without any luck. It appears work for the whole page if i add it to the uiOutput("testUI) %>% withSpinner(), but the page is just blank while the plot is loading.

Hi @PaulC91, I'm just getting started with shinyauthr and it seems pretty straightforward. Thanks for putting this package together. I'm noticing that the login button has a color: white; attribute which is a bit difficult to read:

Simply removing the attribute makes it much easier to see:

Associated PR coming shortly.

Thanks!

This will be resolved by #59

Thank you very much for developing this package, which perfectly solves the user and role rights issues. Here are a few half-baked suggestions I'd like you to consider：

1. Can the login window be placed in the center of the display? Otherwise, the user needs to look up.
2. User name and password are usually not very long, can you make the input box a little shorter?
3. Increase the height of the entire login window, similar to RStudio Server.
4. Added the args to customize the background color of the login window.

Thanks.

Hey @PaulC91 , congratulations for shinyauthr, it is a very useful package!

Do you plan to submit to CRAN? It would be nice because it would facilitate the access and also be covered by RStudio Package Manager.

Thank you

Hi Paul,

Thanks a lot for this package! I'm very new to RShiny, and have made a very simple app without reactive elements. I'm trying to add a login screen to the app using shinyauthr based on the example on the README page on Github. The login dialog box and logout button show up as expected. But for some reason, the rest of the app shows below the login dialog box even if the user is not logged in (see attached images).

Here's a short app to demonstrate the problem. Like this example, my app does not have any reactive elements that are displayed through the server function. So my server function is empty except for the lines required for shinyauthr.

library(shiny)
library(shinydashboard)
library(shinyauthr)

# dataframe that holds usernames, passwords and other user data
user_base <- tibble::tibble(
  user = c("user1", "user2"),
  password = c("pass1", "pass2"),
  permissions = c("admin", "standard"),
  name = c("User One", "User Two")
)

####### Define UI for application #######
ui <- fluidPage(
  title = "Pattern Completion",
  # Application title
  titlePanel(HTML("<center>Data from New Exp</center>")),
  # add logout button UI
  div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
  # add login panel UI function
  shinyauthr::loginUI(id = "login"),
  dashboardPage(
    dashboardHeader(title=""),
    dashboardSidebar(
      sidebarMenu(
        menuItem("Pilot Experiment", tabName= "enc_pilot",startExpanded = TRUE,
                 menuSubItem("Method", tabName="enc_pilot_method", icon=icon(name="tools", lib="font-awesome")),
                 menuSubItem("Results", tabName="enc_pilot_results", icon=icon(name="chart-line", lib="font-awesome")))
      ) #sidebarMenu
    ), #dashboardSidebar
    dashboardBody(
      tabItems(
        tabItem(tabName="enc_pilot_method",
                h2(HTML("<center>METHOD</center>")),
                fluidRow(
                  box(width=12,
                      p(HTML("<strong>Objective:</strong> Some info goes here")),
                  ),
                  box(width=12,
                      h3("Study Phase"),
                      p("More info goes here."),
                  ),
                  box(width=12,
                      h3("Test Phase"),
                      p("Last box here."),
                  ) #box 
                ) #fluidRow
        ), #tabItem enc_pilot_method
        tabItem(tabName="enc_pilot_results",
                h2(HTML("<center>RESULTS</center>")),
                fluidRow(
                  box(width=12,
                      h3("Results go here"),
                  ), #box
                  box(width=12,
                      h3("More results"),
                  ), #box
                ) #fluidRow
        ) #tabItem enc_pilot_results
      ) #tabItems
    ) #dashboardBody
  ) #dashboardPage 
) #ui

####### Define server logic #######
server <- function(input, output, session) {
  
  # call login module supplying data frame, 
  # user and password cols and reactive trigger
  credentials <- shinyauthr::loginServer(
    id = "login",
    data = user_base,
    user_col = user,
    pwd_col = password,
    log_out = reactive(logout_init())
  )
  
  # call the logout module with reactive trigger to hide/show
  logout_init <- shinyauthr::logoutServer(
    id = "logout",
    active = reactive(credentials()$user_auth)
  )
  
  output$user_table <- renderTable({
    # use req to only render results when credentials()$user_auth is TRUE
    req(credentials()$user_auth)
    credentials()$info
  })
}

shinyApp(ui = ui, server = server)

Any suggestions on how to fix this?

Thank you,
Mrinmayi

Using standard hasing algorithms from digest for passwords is not secure (anymore). You are vulnerable to a number of attacks, in particular to brute-force attacks.

I would suggest using a dedicated password hashing algorithm like scrypt, bcrypt, argon2 etc. More on this here: https://download.libsodium.org/doc/password_hashing/

The function deriving a key from a password and a salt is CPU intensive and
intentionally requires a fair amount of memory. Therefore, it mitigates
brute-force attacks by requiring a significant effort to verify each password.

The sodium package implements something very nice:

sodium::password_store(password = "wat")
#> [1] "$7$C6..../....HHM5gAOk/6vdFKYFjG0a6MXPtKkljccJax.tfl5mJL4$5m0cYitpFUdswBbOEL51Jd8L5AtodOOu0FonRzn0UlA"
sodium::password_verify(sodium::password_store(password = "wat"), "wat")
#> [1] TRUE

I cant install the Package "shinyauthr" using the below line
remotes::install_github("paulc91/shinyauthr")

I got the following Error:
Downloading GitHub repo paulc91/shinyauthr@master
Error in utils::download.file(url, path, method = method, quiet = quiet, :
cannot open URL 'https://api.github.com/repos/paulc91/shinyauthr/tarball/master'

Any advice,
Amr

Your package example looks really promising.
However, when I try to install shinyauthr via devtools::install_github("paulc91/shinyauthr") the following error occurs:

Error: HTTP error 422.
  No commit found for SHA: v1.2-rc

  Rate limit remaining: 51/60
  Rate limit reset at: 2018-12-06 09:16:22 UTC

  
In addition: Warning messages:
1: In untar2(tarfile, files, list, exdir) :
  skipping pax global extended headers
2: In untar2(tarfile, files, list, exdir) :
  skipping pax global extended headers

> sessionInfo()
R version 3.5.1 (2018-07-02)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1

Matrix products: default

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base

other attached packages:
[1] usethis_1.4.0  devtools_2.0.1

loaded via a namespace (and not attached):
 [1] Rcpp_1.0.0        ps_1.2.1          prettyunits_1.0.2 rprojroot_1.3-2
 [5] withr_2.1.2       digest_0.6.18     crayon_1.3.4      assertthat_0.2.0
 [9] R6_2.3.0          backports_1.1.2   magrittr_1.5      rlang_0.3.0.1
[13] debugme_1.1.0     cli_1.0.1         curl_3.2          fs_1.2.6
[17] remotes_2.0.2     testthat_2.0.1    callr_3.0.0       desc_1.2.0
[21] tools_3.5.1       glue_1.3.0        pkgload_1.0.2     compiler_3.5.1
[25] processx_3.2.0    base64enc_0.1-3   pkgbuild_1.0.2    sessioninfo_1.1.1
[29] memoise_1.1.0

Love this tool. Only one that works for my specific needs. Thank you for sharing. I have 1 problem where my Shiny app is on a server and if I add new users with a password the shinyauthr will not fetch the latest user/password from the database. Instead it uses the user/password list that was fetch during the first launch. The work around is to restart the shiny app which is not a good solution for me.

How would I trigger to check for the latest user/password list when the user clicks on the "Log in" button?

closing... same issue as #19

AFAICT, logoutUI simply wraps arround shiny::actionButton but does not allow to pass an icon to that button. I think this could be resolved by simply adding ... to the argument list.
I could provide a PR if there is interest.

Hi,

I am using the package and it works just perfect, thank you a lot.

Is there an option to add some extra HTML under the login menu?

Something like: if you forgot your password please contact us at [email protected]

To be just under or somewhere on this screen.

Thank you

Hi Paul,
I am trying to configure your logout.R to add a pop-out window. What I want to achieve is to transfer current log-out button to a modal button and then logout by activating an actionbutton added to modalDialog. But what I got is a pop-out window when log-in.
Could you tell me which part I should change? I must added to the wrong location.

Thanks a lot.

The newest version.
Each user would lose their login information once refreshed the page.

Thank you for great package!
Are there any tricks for using Shinyauth with Flexdashboard instead of pure Shiny and/or Shinydashboard?
I have tried with no success.

Dear Paul, your package is really great, I'm learning this package, I saw that you gave several cases, but I'm currently using tinyMobile (https://github.com/RinteRface/shinyMobile), I tried many times, but did not succeed, can you give a simple case with shinyMobile,thank you very much!

How would I go about using Shinyauthr with UI elements such as navbarPage, navbarMenu, and tabPanel.

    ui <- shinyUI(

        navbarPage("A Nice Title",
                     
                 navbarMenu("A Menu",
                      
                     tabPanel("With",

                        tabPanel("Tabs"))))

placing the shinyauthr::loginUI between any of these shiny pages, menus, and panels results in nonfunctional outputs.

I've also tried storing the ui in a renderUI function, but the navbarPage does not appear. Is Shinyauthr able to work with these shiny elements, is there a possible workaround?

Since the latest update I'm getting two errors when trying to start my app:

Warning: Error in <observer:observeEvent(log_out())>: object 'js' not found
  [No stack trace available]
Warning: Error in shiny::isTruthy: object 'js' not found
  [No stack trace available]

I assume I'm doing something unintended, as your example app works without a problem. Happy to try and dig further, I was just hoping maybe you would have a quick idea of what might be going on. Thank you very much!

Hi Paul,

Would it be possible to answer this question
Basically I would like to display my sidebar panel to user 1 and MainPanel table to user 2.

Below is my code:

#Storing data on Local Machine
library(shiny)
library(ggplot2)

outputDir <- "responses"

# Define the fields we want to save from the form
fields <- c("name", "address","used_shiny", "r_num_years","select")

#Which fields are mandatory
fieldsMandatory<-c("name","address")


labelMandatory <- function(label) {
  tagList(
    label,
    span("*", class = "mandatory_star")
  )
}

appCSS <-
  ".mandatory_star { color: red; }
#error { color: red; }"


saveData <- function(input) {
  # put variables in a data frame
  data <- data.frame(matrix(nrow=1,ncol=0))
  for (x in fields) {
    var <- input[[x]]
    if (length(var) > 1 ) {
      # handles lists from checkboxGroup and multiple Select
      data[[x]] <- list(var)
    } else {
      # all other data types
      data[[x]] <- var
    }
  }
  data$submit_time <- date()

  # Create a unique file name
  fileName <- sprintf(
    "%s_%s.rds", 
    as.integer(Sys.time()), 
    digest::digest(data)
  )

  # Write the file to the local system
  saveRDS(
    object = data,
    file = file.path(outputDir, fileName)
  )
}

loadData <- function() {
  # read all the files into a list
  files <- list.files(outputDir, full.names = TRUE)

  if (length(files) == 0) {
    # create empty data frame with correct columns
    field_list <- c(fields, "submit_time")
    data <- data.frame(matrix(ncol = length(field_list), nrow = 0))
    names(data) <- field_list
  } else {
    data <- lapply(files, function(x) readRDS(x)) 

    # Concatenate all data together into one data.frame
    data <- do.call(rbind, data)
  }

  data
}

deleteData <- function() {
  # Read all the files into a list
  files <- list.files(outputDir, full.names = TRUE)

  lapply(files, file.remove)
}

resetForm <- function(session) {
  # reset values
  updateTextInput(session, "name", value = "")
  updateTextInput(session, "address", value = "")
  updateCheckboxInput(session, "used_shiny", value = FALSE)
  updateSliderInput(session, "r_num_years", value = 0)
  updateSelectInput(session,"select",selected = 'NULL')
}



ui <- fluidPage(
  shinyjs::useShinyjs(),
  shinyjs::inlineCSS(appCSS),

  # App title ----
  titlePanel("Data Collection & Feedback"),

  # Sidebar layout with input and output definitions ----
  sidebarLayout(

    # Sidebar panel for inputs ----
    sidebarPanel(
      div(id='form',
          textInput("name", labelMandatory("Name"), ""),
          textInput("address",labelMandatory('address'),""),
          checkboxInput("used_shiny", "I've built a Shiny app before", FALSE),
          sliderInput("r_num_years", "Number of years using R",
                      0, 10, 0, ticks = FALSE),
          selectInput("select","select",choices = c('a','e','i')),
          actionButton("submit", "Submit",class='btn-primary'),
          actionButton("clear", "Clear Form"),
          downloadButton("downloadData", "Download"),
          actionButton("delete", "Delete All Data"),


          shinyjs::hidden(
            span(id = "submit_msg", "Submitting..."),
            div(id = "error",
                div(br(), tags$b("Error: "), span(id = "error_msg"))
            )
          )

      ),  
      shinyjs::hidden(
        div(
          id = "thankyou_msg",
          h3("Thanks, your response was submitted successfully!"),
          actionLink("submit_another", "Submit another response")
        )
      )  
    ),

    # Main panel for displaying outputs ----
    mainPanel(
      dataTableOutput("responses")
    )
  )
)
server = function(input, output, session) {
  # Enable the Submit button when all mandatory fields are filled out
  observe({
    mandatoryFilled <-
      vapply(fieldsMandatory,
             function(x) {
               !is.null(input[[x]]) && input[[x]] != ""
             },
             logical(1))
    mandatoryFilled <- all(mandatoryFilled)

    shinyjs::toggleState(id = "submit", condition = mandatoryFilled)
  })



  # When the Submit button is clicked, save the form data
  observeEvent(input$submit, {
    #saveData(input)
    #resetForm(session)
    shinyjs::disable("submit")
    shinyjs::show("submit_msg")
    shinyjs::hide("error")

    tryCatch({
      saveData(input)
      shinyjs::reset("form")
      shinyjs::hide("form")
      shinyjs::show("thankyou_msg")
    },
    error = function(err) {
      shinyjs::html("error_msg", err$message)
      shinyjs::show(id = "error", anim = TRUE, animType = "fade")
    },
    finally = {
      shinyjs::enable("submit")
      shinyjs::hide("submit_msg")
    })
  })

  observeEvent(input$submit_another, {
    shinyjs::show("form")
    shinyjs::hide("thankyou_msg")
  })   
  observeEvent(input$clear, {
    resetForm(session)
  })

  # When the Delete button is clicked, delete all of the saved data files
  observeEvent(input$delete, {
    deleteData()
  })

  # Show the previous responses in a reactive table ----
  output$responses <- renderDataTable({
    # update with current response when Submit or Delete are clicked
    input$submit 
    input$delete

    loadData()
  })


  # Downloadable csv of selected dataset ----
  output$downloadData <- downloadHandler(
    filename= "data.csv",

    content = function(file) {
      write.csv(loadData(), file, row.names = FALSE, quote= TRUE)
    }
  )
}

shinyApp(ui, server)

Thanks in advance,

The inside of the package loginUI title cannot support Simple Chinese display function parameters, unable to work at run time. Is there a way to solve?
Thank U very much

Paul, Thanks for a very useful package.
I wonder whether the shinyauthr package also can be used with a shiny-rmarkdown document?

Up to now, I tried to call the shiny-rmd App (myshinyrmarkdown.Rmd) within the app.R below, but I receive an error that we cannot call run_App() within run_App() - is there an 'easy' way to achieve this?

Thanks in advance for a short clarification.

library(shinyauthr)
library(shiny)

user_base <- tibble::tibble(
 user = c("user1", "user2", "user3"),
 password = sapply(c("pass1", "pass2", "pass3"), sodium::password_store),
 permissions = c("admin", "admin", "standard"),
 name = c("U1","U2","U3")
)
ui <- fluidPage(
 # logout button
 div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
  
 shinyauthr::loginUI(id = "login"),
  
 uiOutput("sidebarpanel"),
 
)

server <- function(input, output, session) {

 credentials <- shinyauthr::loginServer(
   id = "login",
   data = user_base,
   user_col = user,
   pwd_col = password,
   sodium_hashed = TRUE,
   log_out = reactive(logout_init())
 ) 
 logout_init <- shinyauthr::logoutServer(
   id = "logout",
   active = reactive(credentials()$user_auth)
 )
 
 output$sidebarpanel <- renderUI({
    
   req(credentials()$user_auth)
   rmarkdown::run("myshinyrmarkdown.Rmd")
    
})
}
shinyApp(ui = ui, server = server)

Thank you for your package, it saves a lot!

I want to use user_info()$permissions == "..." to control the appearance of certain tabPanel() in fluidPage(). It works when first login, but after logout, the re-login process requires to refresh the web-page, other wise the web-page just not render the uiOutput("2") and uiOutput("3"), as well as the glue() in sidebar.

Do you have any idea why this happens?

ui <- dashboardPage(header = dashboardHeader(), 
                    sidebar = dashboardSidebar(), 
                    body = dashboardBody(
  shinyjs::useShinyjs(),
  tags$head(tags$style(".table{margin: 0 auto;}"),
            tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/iframe-resizer/3.5.16/iframeResizer.contentWindow.min.js",
                        type="text/javascript"),
            includeScript("returnClick.js")
  ),
  shinyauthr::loginUI("login"),
  uiOutput("prelogin"), # same as uiOutput("user_table") in your example
  uiOutput("afterlogin"), # here i encountered issue
  HTML('<div data-iframe-height></div>')
))

server <- function(input, output, session) {
  output$afterlogin <- renderUI({
    afterloginUI()
  })
  
  ## issue may related to here
  afterloginUI <- reactive({
    req(credentials()$user_auth)
    
    if (user_info()$permissions == "standard") {
      
      fluidPage(
        tabsetPanel(type = "tabs",
                    tabPanel("1", uiOutput("1")),
                    tabPanel("2", uiOutput("2"))
                    )
        )
      } else if (user_info()$permissions == "admin") {
      
      fluidPage(
        tabsetPanel(type = "tabs",
                    tabPanel("1", uiOutput("1")),
                    tabPanel("2", uiOutput("2")),
                    tabPanel("3", uiOutput("3"))
                    )
        )
      }
    })
  }

Note: for uiOutput("2") and uiOutput("3"), there are calls in their server like observe({}) and observeEvent({}), this is the major difference between uiOutput("1").

Thanks in advance!

I'm trying to add signup functionality. I'm using the prescribed code for login verification:

credentials <- callModule(
    module = shinyauthr::login,
    id = "login", 
    data = user_base,
    user_col = user,
    pwd_col = password_hash,
    sodium_hashed = TRUE,
    log_out = reactive(logout_init()))

In the above code, user_base is a global variable. I tried to use reactive() and eventReactive() to replace the data, but got the following error:

Error in UseMethod("tbl_vars") :
no applicable method for 'tbl_vars' applied to an object of class "c('reactiveExpr', 'reactive')"

Refreshing the page does not help, but I'm able to login with the previously created user after restarting the application (because global variable user_base gets updated). But I'm unable to login with any user ID that's created in the current session.

Desired output:

On click of signup, a new row gets added to user_base during the same session. Login attempt should be successful with the new user.

Is it possible to add the logout button in the User panel of the shinydashboardPlus' dashboardUser interface? When adding the button as it is, the button is not visible. Builing an own function without the hide function solves the problem, but then the login panel is not showing up after logout.

Hey Paul, is there a way to temporarily disable shinyauthr login? This would be very handy in the testing phase of the app, when the developer might just want to focus on the main website development, bypassing the authorization step, saving time.
Thank you.

Hi, Hope you are doing well.
I am trying to execute your example (shinyauthr_example). After execution, it becomes closed and generated an error of

Warning: Error in : in shinyauthr::login module call. Argument hashed is deprecated. shinyauthr now uses the sodium package for password hashing and decryption. If you had previously hashed your passwords with the digest package to use with shinyauthr, please re-hash them with sodium and use the sodium_hashed argument instead for decryption to work. Sorry for this breaking change but sodium hashing provides added protection against brute-force attacks on stored passwords.

54: stop
53: module
48: callModule
47: server [C:\shiny-examples\shinyauthr_example/app.R#43]

Error : in shinyauthr::login module call. Argument hashed is deprecated. shinyauthr now uses the sodium package for password hashing and decryption. If you had previously hashed your passwords with the digest package to use with shinyauthr, please re-hash them with sodium and use the sodium_hashed argument instead for decryption to work. Sorry for this breaking change but sodium hashing provides added protection against brute-force attacks on stored passwords.

Thanks,

I am getting this error in Rv4.0.4 and v4.0.5 and when I commented out below lines from the server the app runs perfectly.

logout_init <- callModule(shinyauthr::logout,
id = "logout",
active = reactive(credentials()$user_auth))

credentials <- callModule(shinyauthr::login,
id = "login",
data = user_base,
user_col = user,
pwd_col = password,
log_out = reactive(logout_init())
)

Any help much appreciated.

First of all, thanks for this awesome package.

I have tried to replicate the example app (https://github.com/PaulC91/shinyauthr/blob/master/inst/shiny-examples/shinyauthr_example/app.R) which runs perfectly fine locally, but not working on shinyapp.io

I have checked the logs but there are no errors. After deployment, I can just see the black screen. Any suggestions on what could be the issue?

Hey,
First of all: Thanks for the great package.
I found out that you can't log in, if the passwort contains the character §. Don't know if there are other characters which will cause that bug also, I didn't find out.
Minimal example:
Just run your example app with:
user_base <- data.frame(user = "test", password = "§test")
It will always say "Invalid username or password!"
Also if § isn't the first character, it will cause this bug.

Hi, Paul!

Thank you for the great package.

A small issue. I tried to set the parameter "sodium_hashed = TRUE" as you described in the package description:

credentials <- callModule(shinyauthr::login, "login", 
                          data = user_base, user_col = user, pwd_col = password,
                          sodium_hashed = TRUE,
                          log_out = reactive(logout_init()))

And, get an error as it seems this parameter is not in the list of available parameters.

Maybe there is some method how to protect passwords or how to change the default value for "sodium_hashed" parameter?

Thanks!

Andrii

Great package, it's been really useful - thanks!

On logout, whatever is visible in a dashboard body stays visible, and the login prompt simply pushes it down. Is there a way to intercept the logout and set to a blank tab - or a simpler option?

library(shiny)
library(shinyauthr)
library(shinyjs)
library(shinydashboard)

# dataframe that holds usernames, passwords and other user data
user_base <- data.frame(
  user = c("user1", "a"),
  password = c("pass1", ""),
  permissions = c("admin", "standard"),
  name = c("User One", "User Two"),
  stringsAsFactors = FALSE
)

header  <- dashboardHeader(title = 'Shiny Auth Test')
sidebar <- dashboardSidebar(
                 shinyauthr::logoutUI(id = 'logout', label = 'Log out', icon = icon('times-circle'))
                ,uiOutput('sidebarpanel')
                )
body    <- dashboardBody(
                 useShinyjs()
                ,shinyauthr::loginUI('login')
                ,uiOutput('body')
                )
ui      <- dashboardPage(header, sidebar, body, skin = 'purple')

server <- function(input, output, session) {

  # call the logout module with reactive trigger to hide/show
  logout_init <- callModule(shinyauthr::logout,
                            id = "logout",
                            active = reactive(credentials()$user_auth))

  # call login module supplying data frame, user and password cols
  # and reactive trigger
  credentials <- callModule(shinyauthr::login,
                            id = "login",
                            data = user_base,
                            user_col = user,
                            pwd_col = password,
                            log_out = reactive(logout_init()))

  # pulls out the user information returned from login module
  user_data <- reactive({credentials()$info})

  output$sidebarpanel <- renderUI({
    req(credentials()$user_auth)
    div(
        sidebarMenu(id = "sidebar"
            ,menuItem('Chart',  tabName = 't_item1', icon = icon('chart-bar'))
            ,menuItem('Widget', tabName = 't_item2', icon = icon('ambulance'))
            ,menuItem(''      , tabName = 't_blank')
        )
    )
  })

  output$body <- renderUI({
    tabItems(
         tabItem(tabName = "t_item1", h2("Chart tab content"))
        ,tabItem(tabName = "t_item2", h2("Widget tab content"))
        ,tabItem(tabName = "t_blank", h2(''))
      )
  })
}

shinyApp(ui = ui, server = server)

Hello,

Thanks for this package. It helps me a lot.

However, as said in the title, I always have to enter my passwords when using said package (I guess this will always happen when I'll open a shiny UI for login in).

Maybe there's some workaround, but I can't find it myself.

Maybe you know how to do that.

Thanks in advance.

library(shinyauthr)
shinyauthr::runExample("basic")
Error: shinyjs: Error parsing the JavaScript code provided.

Thanks a lot for the package, with some basic db logic to store/retrieve user credentials it has become my go-to to implement basic auth in Shiny.

I think unit tests are needed to guard the package from bugs, testthat is probably your best go-to on this one.

Hi, I'm trying to change the password during the run-time.
Therefore i have a input-field (id=newPW) where the User can enter his new password and a Button to confirm (id=changePW).
I try to change it by the following code:

observeEvent(input$changePW,{
credentials()$info$password <- input$newPW
})

Unfortunately I'm always getting the following error:
Warning: Error in <-: invalid (NULL) left side of assignment

Does anybody have an Idee how to change the data that is stored in credentials?

With current arrangement of pulling userBase for authentication, problem arises if you change the password while the user is in session. As the program does not refresh userBase, the old password would still be in effect until reloading the session.

I can think of two ways to fix this issue:

1. Refresh userBase immediately after changeUserPassword. Or
2. Force a refresh, or a session$reload() upon logout.

I can do 1 to get around this issue for now, but I think option 2 is also worth considering.

Edit: also, is there a way to refresh credentials?

Hi Paul, you have done a superb job, but is there any way to change the text displayed in the log in screen, even the button text. I will use this package in another country, so I need text in my native language.
Thnks in advance!!!

Hi and thanks for the great package!

Is it possible to log (or to limit) password failures with shinyauthr? I only figure out to log successful log-ins.
Thanks :)

Is it possible to use shinyauthr inside a shiny app like superzip? I tried the following:

UI

library(leaflet)
library(shinyauthr)
library(shinyjs)

# Choices for drop-downs
vars <- c(
  "Is SuperZIP?" = "superzip",
  "Centile score" = "centile",
  "College education" = "college",
  "Median income" = "income",
  "Population" = "adultpop"
)


fluidPage(
  # must turn shinyjs on
  shinyjs::useShinyjs(),
  # add logout button UI 
  div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
  # add login panel UI function
  shinyauthr::loginUI(id = "login"),
  # setup table output to show user info after login
  uiOutput("superzip")
)

Server

library(leaflet)
library(RColorBrewer)
library(scales)
library(lattice)
library(dplyr)

user_base <- data.frame(
  user = c("user1", "user2"),
  password = c("pass1", "pass2"), 
  permissions = c("admin", "standard"),
  name = c("User One", "User Two"),
  stringsAsFactors = FALSE,
  row.names = NULL
)

# Leaflet bindings are a bit slow; for now we'll just sample to compensate
set.seed(100)
zipdata <- allzips[sample.int(nrow(allzips), 10000),]
# By ordering by centile, we ensure that the (comparatively rare) SuperZIPs
# will be drawn last and thus be easier to see
zipdata <- zipdata[order(zipdata$centile),]

function(input, output, session) {
  
  # call the logout module with reactive trigger to hide/show
  logout_init <- callModule(shinyauthr::logout, 
                            id = "logout", 
                            active = reactive(credentials()$user_auth))
  
  # call login module supplying data frame, user and password cols
  # and reactive trigger
  credentials <- callModule(shinyauthr::login, 
                            id = "login", 
                            data = user_base,
                            user_col = user,
                            pwd_col = password,
                            log_out = reactive(logout_init()))
  
  # pulls out the user information returned from login module
  user_data <- reactive({credentials()$info})

  ## Interactive Map ###########################################

  # Create the map
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles(
        urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
        attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>'
      ) %>%
      setView(lng = -93.85, lat = 37.45, zoom = 4)
  })

  # A reactive expression that returns the set of zips that are
  # in bounds right now
  zipsInBounds <- reactive({
    if (is.null(input$map_bounds))
      return(zipdata[FALSE,])
    bounds <- input$map_bounds
    latRng <- range(bounds$north, bounds$south)
    lngRng <- range(bounds$east, bounds$west)

    subset(zipdata,
      latitude >= latRng[1] & latitude <= latRng[2] &
        longitude >= lngRng[1] & longitude <= lngRng[2])
  })

  # Precalculate the breaks we'll need for the two histograms
  centileBreaks <- hist(plot = FALSE, allzips$centile, breaks = 20)$breaks

  output$histCentile <- renderPlot({
    # If no zipcodes are in view, don't plot
    if (nrow(zipsInBounds()) == 0)
      return(NULL)

    hist(zipsInBounds()$centile,
      breaks = centileBreaks,
      main = "SuperZIP score (visible zips)",
      xlab = "Percentile",
      xlim = range(allzips$centile),
      col = '#00DD00',
      border = 'white')
  })

  output$scatterCollegeIncome <- renderPlot({
    # If no zipcodes are in view, don't plot
    if (nrow(zipsInBounds()) == 0)
      return(NULL)

    print(xyplot(income ~ college, data = zipsInBounds(), xlim = range(allzips$college), ylim = range(allzips$income)))
  })

  # This observer is responsible for maintaining the circles and legend,
  # according to the variables the user has chosen to map to color and size.
  observe({
    # use req to only render results when credentials()$user_auth is TRUE
    req(credentials()$user_auth)
    # 
    colorBy <- input$color
    sizeBy <- input$size

    if (colorBy == "superzip") {
      # Color and palette are treated specially in the "superzip" case, because
      # the values are categorical instead of continuous.
      colorData <- ifelse(zipdata$centile >= (100 - input$threshold), "yes", "no")
      pal <- colorFactor("viridis", colorData)
    } else {
      colorData <- zipdata[[colorBy]]
      pal <- colorBin("viridis", colorData, 7, pretty = FALSE)
    }

    if (sizeBy == "superzip") {
      # Radius is treated specially in the "superzip" case.
      radius <- ifelse(zipdata$centile >= (100 - input$threshold), 30000, 3000)
    } else {
      radius <- zipdata[[sizeBy]] / max(zipdata[[sizeBy]]) * 30000
    }

    leafletProxy("map", data = zipdata) %>%
      clearShapes() %>%
      addCircles(~longitude, ~latitude, radius=radius, layerId=~zipcode,
        stroke=FALSE, fillOpacity=0.4, fillColor=pal(colorData)) %>%
      addLegend("bottomleft", pal=pal, values=colorData, title=colorBy,
        layerId="colorLegend")
  })

  # Show a popup at the given location
  showZipcodePopup <- function(zipcode, lat, lng) {
    selectedZip <- allzips[allzips$zipcode == zipcode,]
    content <- as.character(tagList(
      tags$h4("Score:", as.integer(selectedZip$centile)),
      tags$strong(HTML(sprintf("%s, %s %s",
        selectedZip$city.x, selectedZip$state.x, selectedZip$zipcode
      ))), tags$br(),
      sprintf("Median household income: %s", dollar(selectedZip$income * 1000)), tags$br(),
      sprintf("Percent of adults with BA: %s%%", as.integer(selectedZip$college)), tags$br(),
      sprintf("Adult population: %s", selectedZip$adultpop)
    ))
    leafletProxy("map") %>% addPopups(lng, lat, content, layerId = zipcode)
  }

  # When map is clicked, show a popup with city info
  observe({
    leafletProxy("map") %>% clearPopups()
    event <- input$map_shape_click
    if (is.null(event))
      return()

    isolate({
      showZipcodePopup(event$id, event$lat, event$lng)
    })
  })


  ## Data Explorer ###########################################

  observe({
    cities <- if (is.null(input$states)) character(0) else {
      filter(cleantable, State %in% input$states) %>%
        `$`('City') %>%
        unique() %>%
        sort()
    }
    stillSelected <- isolate(input$cities[input$cities %in% cities])
    updateSelectInput(session, "cities", choices = cities,
      selected = stillSelected)
  })

  observe({
    zipcodes <- if (is.null(input$states)) character(0) else {
      cleantable %>%
        filter(State %in% input$states,
          is.null(input$cities) | City %in% input$cities) %>%
        `$`('Zipcode') %>%
        unique() %>%
        sort()
    }
    stillSelected <- isolate(input$zipcodes[input$zipcodes %in% zipcodes])
    updateSelectInput(session, "zipcodes", choices = zipcodes,
      selected = stillSelected)
  })

  observe({
    if (is.null(input$goto))
      return()
    isolate({
      map <- leafletProxy("map")
      map %>% clearPopups()
      dist <- 0.5
      zip <- input$goto$zip
      lat <- input$goto$lat
      lng <- input$goto$lng
      showZipcodePopup(zip, lat, lng)
      map %>% fitBounds(lng - dist, lat - dist, lng + dist, lat + dist)
    })
  })

  output$ziptable <- DT::renderDataTable({
    df <- cleantable %>%
      filter(
        Score >= input$minScore,
        Score <= input$maxScore,
        is.null(input$states) | State %in% input$states,
        is.null(input$cities) | City %in% input$cities,
        is.null(input$zipcodes) | Zipcode %in% input$zipcodes
      ) %>%
      mutate(Action = paste('<a class="go-map" href="" data-lat="', Lat, '" data-long="', Long, '" data-zip="', Zipcode, '"><i class="fa fa-crosshairs"></i></a>', sep=""))
    action <- DT::dataTableAjax(session, df)

    DT::datatable(df, options = list(ajax = list(url = action)), escape = FALSE)
  })
  
  
  output$superzip <- renderUI({
    # use req to only render results when credentials()$user_auth is TRUE
    req(credentials()$user_auth)
    ## The old superzip ui
    navbarPage("Superzip", id="nav",
               
               tabPanel("Interactive map",
                        div(class="outer",
                            
                            tags$head(
                              # Include our custom CSS
                              includeCSS("styles.css"),
                              includeScript("gomap.js")
                            ),
                            
                            # If not using custom CSS, set height of leafletOutput to a number instead of percent
                            leafletOutput("map", width="100%", height="100%"),
                            
                            # Shiny versions prior to 0.11 should use class = "modal" instead.
                            absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
                                          draggable = TRUE, top = 60, left = "auto", right = 20, bottom = "auto",
                                          width = 330, height = "auto",
                                          
                                          h2("ZIP explorer"),
                                          
                                          selectInput("color", "Color", vars),
                                          selectInput("size", "Size", vars, selected = "adultpop"),
                                          conditionalPanel("input.color == 'superzip' || input.size == 'superzip'",
                                                           # Only prompt for threshold when coloring or sizing by superzip
                                                           numericInput("threshold", "SuperZIP threshold (top n percentile)", 5)
                                          ),
                                          
                                          plotOutput("histCentile", height = 200),
                                          plotOutput("scatterCollegeIncome", height = 250)
                            ),
                            
                            tags$div(id="cite",
                                     'Data compiled for ', tags$em('Coming Apart: The State of White America, 1960–2010'), ' by Charles Murray (Crown Forum, 2012).'
                            )
                        )
               ),
               
               tabPanel("Data explorer",
                        fluidRow(
                          column(3,
                                 selectInput("states", "States", c("All states"="", structure(state.abb, names=state.name), "Washington, DC"="DC"), multiple=TRUE)
                          ),
                          column(3,
                                 conditionalPanel("input.states",
                                                  selectInput("cities", "Cities", c("All cities"=""), multiple=TRUE)
                                 )
                          ),
                          column(3,
                                 conditionalPanel("input.states",
                                                  selectInput("zipcodes", "Zipcodes", c("All zipcodes"=""), multiple=TRUE)
                                 )
                          )
                        ),
                        fluidRow(
                          column(1,
                                 numericInput("minScore", "Min score", min=0, max=100, value=0)
                          ),
                          column(1,
                                 numericInput("maxScore", "Max score", min=0, max=100, value=100)
                          )
                        ),
                        hr(),
                        DT::dataTableOutput("ziptable")
               ),
               
               conditionalPanel("false", icon("crosshair"))
    )
  })
  
}

Alas, when I try to run this code I get the following error:

 renderUI [/home/ignacio/learning_shinyauthr/063-superzip-example/server.R#218]

Hi Paul, i have issues with installing shinyauthr in Windows. I am getting the following error message:

devtools::install_github("paulc91/shinyauthr")
Downloading GitHub repo paulc91/shinyauthr@master
WARNING: Rtools is required to build R packages, but is not currently installed.

Please download and install Rtools 3.5 from http://cran.r-project.org/bin/windows/Rtools/.
√ checking for file 'C:\Users\Stratdigm\AppData\Local\Temp\Rtmp0KSrsU\remotesb41a3f7bec\PaulC91-shinyauthr-6830f43/DESCRIPTION' (381ms)

• preparing 'shinyauthr':
  √ checking DESCRIPTION meta-information ...
• checking for LF line-endings in source and make files and shell scripts
• checking for empty or unneeded directories
• building 'shinyauthr_0.0.99.tar.gz'

Installing package into ‘\Mac/Home/Documents/R/win-library/3.6’
(as ‘lib’ is unspecified)
'\Mac\Home\Documents'
CMD.EXE was started with the above path as the current directory.
UNC paths are not supported. Defaulting to Windows directory.

• installing source package 'shinyauthr' ...
  ** using staged installation
  ** R
  ** inst
  ** byte-compile and prepare package for lazy loading
  Error in findpack(package, lib.loc) :
  there is no package called 'shinyauthr'
  Calls: -> findpack
  Execution halted
  ERROR: lazy loading failed for package 'shinyauthr'
• removing '\Mac/Home/Documents/R/win-library/3.6/shinyauthr'
  Error: Failed to install 'shinyauthr' from GitHub:
  (converted from warning) installation of package ‘C:/Users/STRATD~1/AppData/Local/Temp/Rtmp0KSrsU/fileb42aea35df/shinyauthr_0.0.99.tar.gz’ had non-zero exit status
  In addition: Warning messages:
  1: In untar2(tarfile, files, list, exdir) :
  skipping pax global extended headers
  2: In untar2(tarfile, files, list, exdir) :
  skipping pax global extended headers

Along user and pass, Is it possible to add additional condition to enter shiny app?

More concretely, I would like to add date condition, that is date column for specific user have to be grater then today.

Something like this (server part):

  credentials <- callModule(shinyauthr::login, "login", 
                            data = user_base,
                            user_col = user,
                            pwd_col = password_hash,
                            sodium_hashed = TRUE,
                            log_out = reactive(logout_init()))
  
  logout_init <- callModule(shinyauthr::logout, "logout", reactive(credentials()$user_auth))
  
  observe({
    if(credentials()$user_auth) { #  & user_info$enddate > Sys.Date() 
      shinyjs::removeClass(selector = "body", class = "sidebar-collapse")
    } else {
      shinyjs::addClass(selector = "body", class = "sidebar-collapse")
    }
  })
  
  user_info <- reactive({credentials()$info})
  
  output$welcome <- renderText({
    req(credentials()$user_auth)
    
    glue("{user_info()$name}")
  })

Please look at observe part. This code doesn't work, but demonstrate what I want.

Hello,

I'm wondering if its possible to change the background and text colour for the login UI.

I tried using the additional_ui parmeter with div(style = "background-color: lightblue;"), but that didn't seem to work.

Thanks!

Thank you very much for this great package. I have a use case for which we want to implement a token solution. Each token can be used exactly once. Each user can have multiple tokens. Unfortunately, shinyauthr checks that the username entered is unique in the user data. After a short look at the code in the login script I think that this can be easily rewritten. Would you consider this option? If it would help, I could also try to set up an appropriate pull-request.

Where should I put the data for my own app? And I find that through the sidebar, the user can access the data directly and it doesn't block it.

`library(shinydashboard)
library(dplyr)
library(shinycssloaders)
library(shinyWidgets)
library(shinyauthr)
library(shinyjs)

cookie_expiry <- 7
user_base <- data.frame(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
permissions = c("admin", "standard"),
name = c("User One", "User Two"),
stringsAsFactors = FALSE
)

get_sessions_from_db <- function(conn = db, expiry = cookie_expiry) {
dbReadTable(conn, "sessions") %>%
mutate(login_time = ymd_hms(login_time)) %>%
as_tibble() %>%
filter(login_time > now() - days(expiry))
}

add_session_to_db <- function(user, sessionid, conn = db) {
tibble(user = user, sessionid = sessionid, login_time = as.character(now())) %>%
dbWriteTable(conn, "sessions", ., append = TRUE)
}

db <- dbConnect(SQLite(), ":memory:")
dbCreateTable(db, "sessions", c(user = "TEXT", sessionid = "TEXT", login_time = "TEXT"))

user_base <- tibble(
user = c("user1", "user2"),
password = c("pass1", "pass2"),
password_hash = sapply(c("pass1", "pass2"), sodium::password_store),
permissions = c("admin", "standard"),
name = c("User One", "User Two")
)

ui <- dashboardPage(

dashboardHeader(
title = "abc",
tags$li(
class = "dropdown",
style = "padding: 8px;",
shinyauthr::logoutUI("logout")
),

dropdownMenu(
  type = "messages",
  badgeStatus = NULL,
  messageItem("Feedback and suggestions",
              "qwe",
              href = "qwe")
)

),

dashboardSidebar(
collapsed = TRUE,
div(textOutput("welcome"), style = "padding: 20px"),
searchInput(
inputId = "gene",
label = "abcd",
placeholder = "Potential Gene",
value = "abcd",
btnSearch = icon("search"),
width = "100%"
),
sidebarMenu(
menuItem(
"Potential function of the gene",
tabName = "page1",
icon = icon("compass")
),
menuItem(
"Tips for 123 figures",
tabName = "page2",
icon = icon("list")
),
menuItem(
"Gene for adult sample",
tabName = "page3",
icon = icon("lightbulb")
)
)
),

dashboardBody(
shinyauthr::loginUI(
"login",
cookie_expiry = cookie_expiry,
additional_ui = tagList(
tags$p("test the different outputs from the sample logins below
as well as an invalid login attempt.", class = "text-center"),
HTML(knitr::kable(user_base[, -3], format = "html", table.attr = "style='width:100%;'"))
)
),
tabItems(
tabItem(tabName = "page1",
fluidRow(
valueBoxOutput("Potential_Score"),
valueBoxOutput("Multi_species"),
valueBoxOutput("Multi_omics"),

          column(
            width = 12,class = "text-center",
            box(status = "primary",
              plotOutput("123", width = "380px", height = "360px") %>% withSpinner(color = "#EA2027"),
              title = "123",
              width = 4
            ),
            box(status = "warning",
              plotOutput("456", width = "400px", height = "360px") %>% withSpinner(color = "#EE5A24"),
              title = "456",
              width = 4
            ),
            box(status = "success",
              plotOutput("789", width = "350px", height = "360px") %>% withSpinner(color = "#F79F1F"),
              title = "789",
              width = 4
            ),
          ))
        )
          
        ))

)

`
Any advice would be greatly appreciated!

how to customize the shinyauthr loginUI??

First off, would like to thank you for putting all the work in this package. It has made my life simpler.

However, there is always room for improvement and one problem I noticed that I have to re-login in every new window because currently the package doesn't store successful authentication persistently across tabs so want propose a feature : Would anyone be up for collaboration to combine cookie.js to save session-id per user as Cookie with a custom expiry period such that the same user is not required to login again in that time period.

This blog uses this cookie.js and exemplifies its usage in R.

Hi,
First thank you for this package, i find it very useful !

I was wondering if it would be possible to use a submitButton instead of actionButton on the login page.
I did not try but it seems that pressing "Enter" with a submitButton triggers the action (but not actionButton).

I also see that styles don't seem to be available with submitButton (that's why you may have changed to actionButton ?).

Edit :
I guess my issue is related with returnClick.js, isn't it ?
In that case, pressing "Enter" does not work.

Hello.

First of all I would like to thank you for this great clearance package.

In general it works quite well for both login and logout but sometimes I encounter problems when the shiny session gives timeout after a long time.

When you refresh the page with F5 it freezes and on the terminal where the application is running I get these messages.

Warning: Error in UseMethod: no applicable method for 'tbl_vars' applied to an object of class "list"
  69: tbl_vars_dispatch
  66: tbl_vars
  64: tbl_nongroup_vars
  63: tbl_if_vars
  59: tbl_if_syms
  58: manip_if
  57: dplyr::mutate_if
  56: shinyauthr::loginServer
  51: server
   5: shiny::runApp
   4: eval
   3: eval
   1: source
Error in UseMethod("tbl_vars") :
  no applicable method for 'tbl_vars' applied to an object of class "list"

I realise that it is not at all easy to reproduce this error, but perhaps with this information you can guess what might be happening and how to avoid it.

This is the information of the package I have installed, as shown in the R statement sessionInfo()$otherPkgs$shinyauthr

Package: shinyauthr
Type: Package
Title: 'Shiny' Authentication Modules
Version: 1.0.0
Authors@R: c(person(given = "Paul", family = "Campbell", email = "[email protected]", role = c("aut", "cre"), comment =
              c(ORCID = "0000-0003-1018-6606")), person(given = "Michael", family = "Dewar", email = "[email protected]",
              role = "ctb"))
Description: Add in-app user authentication to 'shiny', allowing you to secure publicly hosted apps and build dynamic user
              interfaces from user information.
License: MIT + file LICENSE
Encoding: UTF-8
Imports: shiny (>= 1.5.0), shinyjs, dplyr, rlang, sodium, glue
Suggests: DBI, RSQLite, lubridate, shinydashboard, testthat (>= 3.0.0), shinytest, knitr, rmarkdown, covr
RoxygenNote: 7.1.1
URL: https://github.com/paulc91/shinyauthr
BugReports: https://github.com/paulc91/shinyauthr/issues
Config/testthat/edition: 3
NeedsCompilation: no
Packaged: 2021-07-19 10:41:29 UTC; paul
Author: Paul Campbell [aut, cre] (<https://orcid.org/0000-0003-1018-6606>), Michael Dewar [ctb]
Maintainer: Paul Campbell <[email protected]>
Repository: CRAN
Date/Publication: 2021-07-20 07:20:02 UTC
Built: R 4.1.2; ; 2022-06-12 10:08:22 UTC; unix

Thank you very much in advance

I tried to use shinyauthr in flexdashboard app, use the demo code just work in in one column of dashboard. normally login and logout.

However the login module it dost not hide the content of the dashboard. I know they are not in one ui element.

But in flexdashboard, element were splited in different cols, do it possible use shinyauthr to control the whole app.