Skip to content

Instantly share code, notes, and snippets.

@jbryer jbryer/Login.R
Last active May 15, 2019

Embed
What would you like to do?
# This script is modified by Jason Bryer (jason@bryer.org) from Huidong Tian's
# original script. The blog post describing the method is here:
# http://withr.me/authentication-of-shiny-server-application-using-a-simple-method/
# The original R script is located here: https://gist.github.com/withr/9001831
#
# This script adds two new features: 1. Render a logout button, and 2. provide
# the ability for visitors to create a new account.
#
# Within your server.R file, be sure to use:
#
# source('Login.R', local=TRUE)
#
# To use this file, you can add uiOutput('uiLogin'), uiOutput('uiNewAccount'),
# and uiOutput('uiLogout') anywhere in your shiny application. If you wish to
# have part of you application available only to authenticated users, you can
# checked to see if they are logged in with the USER$Logged field (this is a
# logical). Additional, USER$Username and USER$Group will give the username
# and password of the logged in user, respectively.
# This is the file that contains a data.frame PASSWORD used for authentication.
users.file <- 'users.rda'
default.group <- 'user' # The value for Group when creating new accounts
if(!file.exists(users.file)) {
# Create initial, empty file, otherwise errors will occur below
PASSWORD <- data.frame(Username = character(),
Password = character(),
Group = character(),
Email = character(),
stringsAsFactors = FALSE)
save(PASSWORD, file=users.file)
}
USER <- reactiveValues(Logged = FALSE,
Unique = format(Sys.time(), '%Y%m%d%H%M%S'),
Username = NA,
Email = NA,
Group = NA)
# Password input textbox
passwdInput <- function(inputId, label, value) {
tagList(
tags$label(label),
tags$input(id=inputId, type="password", value=value, class='form-control')
)
}
# Returns a panel for logging in.
output$uiLogin <- renderUI({
wellPanel(
uiOutput('pass'),
div(textInput(paste0("username", USER$Unique),
"Username: ", value='')),
div(passwdInput(paste0("password", USER$Unique),
"Password: ", value='')),
br(),
actionButton("Login", "Login")
)
})
# Provides a UI for creating an account
output$uiNewAccount <- renderUI({
wellPanel(
uiOutput('newuser'),
div(textInput(paste0("newusername", USER$Unique),
"Username: ", value='')),
div(passwdInput(paste0("newpassword1", USER$Unique),
"Password: ", value='')),
div(passwdInput(paste0("newpassword2", USER$Unique),
"Confirm Password: ", value='')),
div(textInput(paste0('newemail', USER$Unique),
"Email Address: ", value='')),
br(),
actionButton("CreateUser", "Create Account")
)
})
# UI for a logout button
output$uiLogout <- renderUI({
actionButton('logoutButton', 'Logout')
})
# Log the user out
observeEvent(input$logoutButton, {
if(!is.null(input$logoutButton) & input$logoutButton == 1) {
USER$Logged <- FALSE
USER$Username <- USER$Group <- NA
USER$Unique <- format(Sys.time(), '%Y%m%d%H%M%S')
USER$Email <- NA
}
})
# Add a new user
output$newuser <- renderText({
text <- ''
if(USER$Logged == FALSE) {
if(!is.null(input$CreateUser)) {
if(input$CreateUser > 0) {
newusername <- input[[paste0('newusername', USER$Unique)]]
newpassword1 <- input[[paste0('newpassword1', USER$Unique)]]
newpassword2 <- input[[paste0('newpassword2', USER$Unique)]]
newemail <- input[[paste0('newemail', USER$Unique)]]
load(users.file)
# Validate input fields
if(is.null(newusername) |
is.null(newpassword1) |
is.null(newpassword2) |
is.null(newemail)) {
text <- 'Please enter all fields'
} else if(nchar(newusername) < 5 |
nchar(newpassword1) < 5) {
text <- 'Please enter username and password with at least 5 characters'
} else if(newpassword1 != newpassword2) {
text <- 'Passwords do not match'
} else if(is.null(newemail) |
nchar(newemail) < 5 |
grep(".+@.+", newemail) < 1) {
text <- 'Invalid email address'
} else if(tolower(newusername) %in% PASSWORD$Username) {
text <- 'Username already exists'
} else { # Add the user
newuser <- data.frame(
Username = newusername,
Password = newpassword1,
Group = 'user',
Email = newemail
)
for(i in names(PASSWORD)[(!names(PASSWORD) %in% names(newuser))]) {
newuser[,i] <- NA # Make sure the data.frames line up
}
PASSWORD <- rbind(PASSWORD, newuser[,names(PASSWORD)])
save(PASSWORD, file=users.file)
USER$Logged <- TRUE
USER$Username <- newusername
USER$Group <- default.group
USER$Email <- newemail
}
}
}
}
text
})
# Log the user in
output$pass <- renderText({
if(USER$Logged == FALSE) {
if(!is.null(input$Login)) {
if(input$Login > 0) {
load(users.file)
Username <- isolate(input[[paste0('username', USER$Unique)]])
Password <- isolate(input[[paste0('password', USER$Unique)]])
Id.username <- which(PASSWORD$Username == tolower(Username))
if(!is.null(Id.username) & length(Id.username) == 1 &
Password == PASSWORD[Id.username,]$Password)
{
USER$Logged <- TRUE
USER$Username <- Username
USER$Group <- PASSWORD[Id.username,]$Group
USER$Email <- PASSWORD[Id.username,]$Email
} else {
"Username or password failed!"
}
}
}
}
})
@jbryer

This comment has been minimized.

Copy link
Owner Author

commented Feb 21, 2016

To use this script, you have to set the local=TRUE on the source function.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.