Using shinymanager with hashed passwords stored in a postgresql database

Question

I want to use the shinymanager package to secure my Rshiny application but I want to use it with a PostgreSQL database...

I checked the example provided in the documentation and the github of the package to eventually create this code that is not working but I don't know why:

library(RPostgreSQL)
library(shiny)
library(shinymanager)
library(DBI)
library(pool)
library(sodium)


dbname = ***********
host =  ***********
user =  ***********
password =  ***********

con <- dbPool(
  drv = dbDriver("PostgreSQL"),
  dbname = dbname , 
  host = host,
  user = user, 
  password = password )

DBI::dbWriteTable(con, c("test", "test2"), data.frame(
  user = c("David"),
  password = sodium::password_store("123"),
  stringsAsFactors = FALSE
))

my_custom_check_creds <- function(dbname, host, user, password) {
  function(user, password) {
    
    con <- dbConnect(drv = dbDriver("PostgreSQL"),  
                     dbname = dbname,
                     host = host,
                     user = user, 
                     password = password)

    req <- sqlInterpolate(con, sql = "SELECT * FROM test.test2 WHERE test2.user = ({user}) AND test2.password = ({password})",
                    user = user, password = password)
    
    res <- dbGetQuery(con, statement = req)
    
    if (nrow(res) > 0) {

  hashed_password <- res$password

  if (sodium::password_verify(hashed_password, password)) {
    list(user = user, password = password, result = TRUE)
    } else {
    list(result = FALSE)
  }
} else {
  list(result = FALSE)
}
 }
  }
  

  ui <- fluidPage(
    tags$h2("My secure application"),
    verbatimTextOutput("auth_output")
  )
  
  ui <- secure_app(ui)
  
  
  server <- function(input, output, session) {
    res_auth <- secure_server(
      check_credentials = my_custom_check_creds
    )  
    output$auth_output <- renderPrint({
      reactiveValuesToList(res_auth)
    })
    
  }
  
  shinyApp(ui, server)

The app is launched but after pressing the log in button the app disconnect and I get a not very informating warning message:

��m)
  [No stack trace available]

Answer 1

Ok, I haven't tested this at all, since I don't have a Postgres server available at the moment, but I've made some adjustments that should hopefully get you closer to a solution.

Note that your database login and password will be (or certainly should be) different than a random users credentials, so they need to be given different argument names in the functions. I'm not entirely clear how the username and password to be authenticated are passed through to the check credentials function, but you've obviously based your attempt on the example from the shinymanager package, so I've just fixed that a little.

library(RPostgreSQL)
library(shiny)
library(shinymanager)
library(DBI)
library(pool)
library(sodium)

dbname <- "***********"
host <- "***********"
db_user <- "***********"
db_password <- "***********"

con <- dbPool(
    drv = dbDriver("PostgreSQL"),
    dbname = dbname , 
    host = host,
    user = db_user, 
    password = db_password)

DBI::dbWriteTable(con, c("test", "test2"), data.frame(
    user = c("David"),
    password = sodium::password_store("123"),
    stringsAsFactors = FALSE
))

my_custom_check_creds <- function(dbname, host, db_user, db_password) { # Database creds
    function(user, password) { # User login creds
        
        con <- dbConnect(drv = dbDriver("PostgreSQL"),  
                         dbname = dbname,
                         host = host,
                         user = db_user,  # These are the database credentials
                         password = db_password)
        
        # Extract user login creds from database
        req <- sqlInterpolate(con, sql = "SELECT * FROM test.test2 WHERE test2.user = ({user}) AND test2.password = ({password})",
                              user = user, password = password)
        
        res <- dbGetQuery(con, statement = req)
        
        if (nrow(res) > 0) {
            
            hashed_password <- res$password
            
            if (sodium::password_verify(hashed_password, password)) {
                list(user = user, password = password, result = TRUE)
            } else {
                list(result = FALSE)
            }
        } else {
            list(result = FALSE)
        }
    }
}

ui <- fluidPage(
    tags$h2("My secure application"),
    verbatimTextOutput("auth_output")
)

ui <- secure_app(ui)

server <- function(input, output, session) {
    res_auth <- secure_server(
        check_credentials = my_custom_check_creds( # Need to call the function here
            dbname, # Pass it the appropriate credentials
            host,
            db_user,
            db_password
        )
    )  
    output$auth_output <- renderPrint({
        reactiveValuesToList(res_auth)
    })
}

shinyApp(ui, server)