在用户使用shinyauthr查看应用程序的任何部分之前，如何要求R Shiny中的用户身份验证？

Question

我有一个 R Shiny 应用程序，我希望用户在看到任何内容（包括主面板和每个选项卡）之前对其进行身份验证。我知道我可以在每个项目之前使用“

req(credentials()$user_auth)

”，但这对于我的主面板来说似乎太过分了。但是，如果我不这样做，看起来会很尴尬：

如何在用户看到任何内容之前要求提供凭据？有没有办法只指定一次 上述-req() 参数？

我知道

shinymanager

可以通过 secureapp() 函数来做到这一点，但据我所知，你不能使用哈希密码。我的应用程序使用钠包来散列密码，因此首选shinyauthr，因为它可以轻松解码。仅当其他解决方案可以使用哈希密码时才开放。

这是一个可重现的示例：

library(shiny)
library(shinyauthr)

user_base <- tibble::tibble(
  user = c("user1", "user2"),
  permissions = c("admin", "standard"),
  name = c("User One", "User Two"),
  pwd_col = "password"
)


ui <- fluidPage(
  # add logout button UI
  div(class = "pull-right", shinyauthr::logoutUI(id = "logout")),
  # add login panel UI function
  shinyauthr::loginUI(id = "login"),
  tabsetPanel(
    tabPanel("View 1", 
  
  h4("Select Your Desired Filters"),
  div(id = "inputs",
      dateRangeInput(
        inputId = "date_filter",
        label = "Filter by Month and Year",
        start = today(),
        end = (today() + 90),
        min = "Apr-2021",
        max = NULL,
        format = "M-yyyy",
        startview = "month",
        weekstart = 0,
        language = "en",
        separator = " to ",
        width = NULL,
        autoclose = TRUE
      ))),
  tabPanel("View 2", 
  # setup table output to show user info after login
  tableOutput("user_table")
)))

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 = pwd_col,
    sodium_hashed = FALSE,
    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)

Answer 1

更新：

虽然我无法使用

shinyauthr

和

sodium

找到答案，但我已经找到了用

shinymanger

和

scyrpt

实现目标的方法。

下面的代码是根据这篇文章的第一个答案修改的，它包含一个加密的密码。要访问该应用程序，密码是“ice”（不带引号）。用户名是“1”，同样不带引号。

重要的部分是在凭证中将

is_hashed_password

参数设置为

TRUE

。它识别的哈希是

scrypt

的方法，而不是

sodium

。

我将把这个问题再保留几天，以防有人能找到我原来问题的答案。否则，我会认为这个等效解决方案是可以接受的：

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)