部署时闪亮的密码导致断开连接

Question

我大致按照Starting Shiny app after password input的说明向我的闪亮应用添加密码。当我在本地运行应用程序时它非常有效，但是当我部署它时，唯一可行的部分是密码页面。输入用户名和密码后，应用程序将断开与服务器的连接。为什么断开连接而不是从ui1切换到ui2？我不确定如何使这个可重现，但我的代码看起来大致如下：

UI

#Load Libraries

#this is really my whole ui.R file
shinyUI(htmlOutput("page"))

server.R

#Load Libraries
#Load Functions And Data

#Define variables to connect to MySQL
databaseName <- "****"
table <- "****"
options(
  mysql = list(
    "host" = "****",
    "port" = 3306,
    "user" = "****",
    "password" = "****"
  )
)

#SQL Data Retrieval Functions From http://deanattali.com/blog/shiny-persistent-data-storage/
saveData <- function(data) {
  # Connect to the database
  db <- dbConnect(MySQL(), dbname = databaseName, host = options()$mysql$host, 
                  port = options()$mysql$port, user = options()$mysql$user, 
                  password = options()$mysql$password)
  # Construct the update query by looping over the data fields
  query <- sprintf(
    "INSERT INTO %s (%s) VALUES ('%s')",
    table, 
    paste(names(data), collapse = ", "),
    paste(data, collapse = "', '")
  )
  # Submit the update query and disconnect
  dbGetQuery(db, query)
  dbDisconnect(db)
}

loadData <- function() {
  # Connect to the database
  db <- dbConnect(MySQL(), dbname = databaseName, host = options()$mysql$host, 
                  port = options()$mysql$port, user = options()$mysql$user, 
                  password = options()$mysql$password)
  # Construct the fetching query
  query <- sprintf("SELECT * FROM %s", table)
  # Submit the fetch query and disconnect
  data <- dbGetQuery(db, query)
  dbDisconnect(db)
  data
}

#define password
#password protection applied based on example here: https://stackoverflow.com/questions/28987622/starting-shiny-app-after-password-input
Logged = FALSE;
my_username <- "Administrator"
my_password <- "****"

#Actual UI
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 <- 
  fluidPage(
            shinyjs::useShinyjs(),
            sidebarPanel(
              #various elements of a sidebar panel
              ),
            mainPanel(
              #various elements of a main panel
            ),
            tabPanel(#tabPanel things),
            tabPanel(#tabPanel things),
            tabPanel(#tabPanel things),
            tabPanel(#tabPanel things)
              )



#Actual Server
server = (function(input, output) {

  #various reactive page elements such as tables, plots, and conditional panels

  #Server Side Password activity
  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({
        ui2
      })
      print(ui)
    }
  })
})

如果这有帮助，请查看控制台日志中发生的情况：

jquery.min.js:4 Synchronous XMLHttpRequest on the main thread is deprecated because of its detrimental effects to the end user's experience. For more help, check https://xhr.spec.whatwg.org/.
send @ jquery.min.js:4
ajax @ jquery.min.js:4
getSettings @ shinyapps.js:39
(anonymous) @ shinyapps.js:1
rstudio-connect.js:384 Mon Mar 06 2017 17:06:28 GMT-0600 (CST): Connection opened. https://zlevine.shinyapps.io/forcafha/
rstudio-connect.js:384 Mon Mar 06 2017 17:07:05 GMT-0600 (CST): Connection closed. Info: {"type":"close","code":1000,"reason":"Normal closure","wasClean":true}

Answer 1

我简化了一下你的代码，它现在按预期工作：

# ui.R
shinyUI(fluidPage(shinyjs::useShinyjs(),uiOutput("page")))

*******************************************************************************************

# server.R
shinyServer(function(input, output) {

  Logged = FALSE;
  my_username <- "Administrator"
  my_password <- "****"

  #Actual UI
  ui1 <-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 <- titlePanel("Loggedin!")

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

  output$page <- renderUI({
    if (USER$Logged == FALSE) 
      div(class="outer",do.call(bootstrapPage,c("",ui1)))
    else 
      ui2
  })
})