Launch shinymanager authentification after click on button in the first tab then display other tabs

Question

I was wondering if it was possible to protect a shiny application with shinymanager but with having the possibility to access the first tab of the app before entering username and password while the second and third tab are hidden ?

I would like a "connect" button to launch the shinymanager page and then display the other tabs.

Does someone know if it is doable or should I use my own authentification form (which means less secured...) ?

My attempt:

library(shiny)
library(shinymanager)
library(shinydashboard)
library(shinyWidgets)
library(shinythemes)

credentials <- data.frame(
  user = c("user1"),
  password = c("1"),
  stringsAsFactors = FALSE
)

# user interface
ui <- navbarPage(id="navbarid",
                 "TEST",  theme = shinytheme("cosmo"),
                 header = tagList(
                   useShinydashboard()),

                 tabPanel(
                   "Welcome", fluidRow(align = "center", 
                        column(6, offset=4,
                               box(title = "Authentification", background = "black", 
                                 fluidRow(column(6, align = "center", style='padding-top:20px;',
                                    actionButton(inputId = "connect", label = "Log in")),
                                          column(6, align = "center", style='padding-top:20px;',
                                    actionButton(inputId = "register", label = "Register here"))))))),

                 tabPanel("Tab2", verbatimTextOutput("label1")
                   ),

                 tabPanel("Tab3", verbatimTextOutput("label2")
                 ))

ui <- secure_app(ui)

server <- function(input, output, session) {
  
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  output$icon1 <- renderText(as.character(icon("sign-in-alt")))
  output$icon2 <- renderText(as.character(icon("users")))

  output$label1 <- renderText("First tab content here")
  output$label2 <- renderText("Second tab content here")
}

shinyApp(ui, server)

I tried to add

observeEvent(input$connect, {
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )})

at the beginning of my server part but it didn't work !

Answer 1

The following is a combination of my earlier answers here and here.

I'm using two separate R sessions - both hosting a shiny app. A parent shiny app with public contents is launched as usual. This app contains an iframe to show the secured contents of the shiny app launched in a child process via callr::r_bg.

A current drawback of this approach is, that shinymanager's logout button can't be used, as it is clearing the query string (reloading the shiny session I guess), which is needed to determine which tab is accessed.

Please check the following:

library(shiny)
library(shinymanager)
library(shinydashboard)
library(shinyWidgets)
library(shinythemes)
library(callr)

secured_ui <- secure_app(fluidPage(uiOutput("iframecontent")), fab_position = "none")

secured_server <- function(input, output, session) {
  credentials <- data.frame(
    user = c("admin", "user1", "user2"),
    password = c("admin", "user1", "user2"),
    admin = c(TRUE, FALSE, FALSE),
    permission = c("advanced", "basic", "basic"),
    job = c("CEO", "CTO", "DRH"),
    stringsAsFactors = FALSE)
  
  res_auth <- shinymanager::secure_server(
    check_credentials = shinymanager::check_credentials(credentials)
  )
  
  output$iframecontent <- renderUI({
    currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    if (is.null(currentQueryString)){
      return(div(h2("There is nothing here", style = "color: red;")))
    } else {
      req(currentQueryString, cancelOutput = TRUE)
      req(res_auth$permission, cancelOutput = TRUE)
      fluidPage(
        if(!is.null(currentQueryString) && currentQueryString == "tab1" && res_auth$permission %in% c("basic", "advanced")){
          div(h2("First tab content here"))
        } else if (!is.null(currentQueryString) && currentQueryString == "tab2" && res_auth$permission == "advanced"){
          div(h2("Second tab content here"))
        } else {
          div(h2("Access not permitted", style = "color: red;"))
        }, theme = shinythemes::shinytheme("cosmo")
      )
    }
  })
}

secured_child_app <- shinyApp(secured_ui, secured_server)

# run secured_child_app in a background R process - not needed when e.g. hosted on shinyapps.io
secured_child_app_process <- callr::r_bg(
  func = function(app) {
    shiny::runApp(
      appDir = app,
      port = 3838L,
      launch.browser = FALSE,
      host = "127.0.0.1" # secured_child_app is accessible only locally (or via the iframe)
    )
  },
  args = list(secured_child_app),
  stdout = "|",
  stderr = "2>&1",
  supervise = TRUE
)

print("Waiting for secured child app to get ready...")
while(!any(grepl("Listening on http", secured_child_app_process$read_output_lines()))){
  Sys.sleep(0.5)
}

public_ui <- navbarPage(id="navbarid",
                        "Secured Tabs Test",
                        theme = shinytheme("cosmo"),
                        header = tagList(useShinydashboard()),
                        tabPanel(
                          "Welcome", h2("Public content here")
                        ),
                        tabPanel("Tab1",
                                 tags$iframe(
                                   src = "http://127.0.0.1:3838/?tab=tab1",
                                   style = "border: none;
                              overflow: hidden;
                              height: calc(100vh - 100px);
                              width : 100vw;
                              position: relative;
                              top:0px;
                              padding:0px;"
                                 )),
                        tabPanel("Tab2", tags$iframe(
                          src = "http://127.0.0.1:3838/?tab=tab2",
                          style = "border: none;
                              overflow: hidden;
                              height: calc(100vh - 100px);
                              width : 100vw;
                              position: relative;
                              top:0px;
                              padding:0px;"
                        ))
)

public_server <- function(input, output, session) {}

public_parent_app <- shinyApp(public_ui, public_server, onStart = function() {
  cat("Doing application setup\n")
  onStop(function() {
    cat("Doing application cleanup\n")
    secured_child_app_process$kill() # kill secured_child_app if public_parent_app is exited - not needed when hosted separately
  })
})

# run public_parent_app
runApp(appDir = public_parent_app,
       port = 3939L,
       launch.browser = TRUE,
       host = "0.0.0.0")