flowchart TD
A["User Request"] --> B["Authentication Layer"]
B --> C["Session Management"]
C --> D["Authorization Check"]
D --> E["Application Access"]
F["Security Components"] --> G["User Authentication"]
F --> H["Role-Based Access"]
F --> I["Session Security"]
F --> J["Data Protection"]
K["Authentication Methods"] --> L["Database Authentication"]
K --> M["OAuth Integration"]
K --> N["LDAP/Active Directory"]
K --> O["Multi-Factor Auth"]
P["Security Measures"] --> Q["Password Security"]
P --> R["Session Encryption"]
P --> S["Input Validation"]
P --> T["Audit Logging"]
style A fill:#e1f5fe
style F fill:#f3e5f5
style K fill:#e8f5e8
style P fill:#fff3e0
Key Takeaways
Tip
- Enterprise Security Standards: Professional authentication systems protect sensitive data and ensure compliance with organizational security policies and regulatory requirements
- Multi-Layer Protection: Comprehensive security combines user authentication, session management, data encryption, and access control for defense-in-depth protection
- Role-Based Access Control: Sophisticated permission systems enable fine-grained access control that scales from simple user/admin roles to complex organizational hierarchies
- Session Security Excellence: Advanced session management prevents unauthorized access, session hijacking, and ensures secure user experiences across different devices and networks
- Audit and Compliance: Complete security logging and monitoring enable compliance reporting, security incident response, and continuous security improvement
Introduction
User authentication and security represent the critical foundation that enables Shiny applications to handle sensitive data, serve multiple users, and meet enterprise security requirements. While basic Shiny applications assume trusted environments, professional applications require comprehensive security measures that protect against unauthorized access, data breaches, and compliance violations.
This comprehensive guide covers the complete spectrum of authentication and security implementation, from basic login systems to sophisticated enterprise security architectures with role-based access control, session management, and compliance monitoring. You’ll master the patterns that transform open applications into secure, auditable systems that meet the stringent requirements of regulated industries and enterprise environments.
The security techniques you’ll learn are essential for any application handling personal data, business intelligence, or sensitive analytics. These implementations enable Shiny applications to serve as secure front-ends for enterprise data systems while maintaining the analytical power and development efficiency that makes Shiny superior for data-driven applications.
Understanding Application Security Architecture
Secure Shiny applications implement multiple layers of protection that work together to ensure authorized access while maintaining user experience and system performance.
Core Security Principles
Authentication: Verifying user identity through credentials, tokens, or external authentication providers before granting system access.
Authorization: Controlling what authenticated users can access and what actions they can perform based on roles and permissions.
Session Management: Secure handling of user sessions including creation, validation, expiration, and cleanup to prevent unauthorized access.
Data Protection: Encryption of sensitive data both in transit and at rest, along with secure handling of user information and business data.
Foundation Authentication Systems
Basic Database Authentication
Start with a comprehensive database-backed authentication system that provides the foundation for enterprise security:
library(shiny)
library(DBI)
library(pool)
library(digest)
library(sodium)
library(uuid)
library(jsonlite)
# Secure authentication manager
create_authentication_system <- function(db_pool) {
# Password security configuration
password_config <- list(
min_length = 8,
require_uppercase = TRUE,
require_lowercase = TRUE,
require_numbers = TRUE,
require_special = TRUE,
special_chars = "!@#$%^&*()_+-=[]{}|;:,.<>?",
max_attempts = 5,
lockout_duration = 900 # 15 minutes in seconds
)
# Password strength validation
validate_password <- function(password) {
errors <- c()
if(nchar(password) < password_config$min_length) {
errors <- c(errors, paste("Password must be at least", password_config$min_length, "characters"))
}
if(password_config$require_uppercase && !grepl("[A-Z]", password)) {
errors <- c(errors, "Password must contain at least one uppercase letter")
}
if(password_config$require_lowercase && !grepl("[a-z]", password)) {
errors <- c(errors, "Password must contain at least one lowercase letter")
}
if(password_config$require_numbers && !grepl("[0-9]", password)) {
errors <- c(errors, "Password must contain at least one number")
}
if(password_config$require_special) {
special_pattern <- paste0("[", gsub("([\\[\\]\\\\^$.|?*+()])", "\\\\\\1", password_config$special_chars), "]")
if(!grepl(special_pattern, password)) {
errors <- c(errors, "Password must contain at least one special character")
}
}
# Check for common weak passwords
weak_passwords <- c("password", "123456", "qwerty", "admin", "letmein")
if(tolower(password) %in% weak_passwords) {
errors <- c(errors, "Password is too common and not allowed")
}
return(list(
valid = length(errors) == 0,
errors = errors
))
}
# Secure password hashing
hash_password <- function(password) {
# Generate random salt
salt <- sodium::random(16) # 16 bytes = 128 bits
# Hash password with salt using Argon2
hash <- sodium::password_store(password)
return(list(
hash = hash,
salt = sodium::bin2hex(salt)
))
}
# Password verification
verify_password <- function(password, stored_hash) {
tryCatch({
# Verify using sodium's secure verification
result <- sodium::password_verify(stored_hash, password)
return(result)
}, error = function(e) {
# Log verification error
cat("Password verification error:", e$message, "\n")
return(FALSE)
})
}
# User registration
register_user <- function(username, email, password, role = "user") {
# Input validation
if(!is.character(username) || nchar(username) < 3 || nchar(username) > 50) {
return(list(success = FALSE, error = "Username must be 3-50 characters"))
}
if(!grepl("^[\\w\\.-]+@[\\w\\.-]+\\.[a-zA-Z]{2,}$", email)) {
return(list(success = FALSE, error = "Invalid email format"))
}
# Validate password strength
password_check <- validate_password(password)
if(!password_check$valid) {
return(list(success = FALSE, error = paste(password_check$errors, collapse = "; ")))
}
# Check if user already exists
existing_user <- pool::dbGetQuery(
db_pool,
"SELECT user_id FROM users WHERE username = $1 OR email = $2",
params = list(username, email)
)
if(nrow(existing_user) > 0) {
return(list(success = FALSE, error = "Username or email already exists"))
}
# Hash password
password_data <- hash_password(password)
tryCatch({
# Insert new user
result <- pool::dbGetQuery(
db_pool,
"
INSERT INTO users (username, email, password_hash, role, active, created_at)
VALUES ($1, $2, $3, $4, TRUE, CURRENT_TIMESTAMP)
RETURNING user_id, username, email, role, created_at
",
params = list(username, email, password_data$hash, role)
)
# Log registration
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details, ip_address)
VALUES ($1, 'user_registration', $2, $3)
",
params = list(
result$user_id,
jsonlite::toJSON(list(username = username, role = role)),
"127.0.0.1" # In production, get real IP
)
)
return(list(
success = TRUE,
user = result[1, ],
message = "User registered successfully"
))
}, error = function(e) {
return(list(success = FALSE, error = paste("Registration failed:", e$message)))
})
}
# User authentication
authenticate_user <- function(username, password, ip_address = "127.0.0.1") {
# Check for account lockout
lockout_check <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as failed_attempts,
MAX(attempt_time) as last_attempt
FROM login_attempts
WHERE username = $1
AND success = FALSE
AND attempt_time > CURRENT_TIMESTAMP - INTERVAL '15 minutes'
",
params = list(username)
)
if(nrow(lockout_check) > 0 && lockout_check$failed_attempts >= password_config$max_attempts) {
# Log lockout attempt
pool::dbExecute(
db_pool,
"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,
jsonlite::toJSON(list(reason = "account_locked"))
)
)
return(list(
success = FALSE,
error = "Account temporarily locked due to too many failed attempts",
locked = TRUE
))
}
# Get user data
user_data <- pool::dbGetQuery(
db_pool,
"
SELECT user_id, username, email, password_hash, role, active,
last_login, failed_login_attempts
FROM users
WHERE username = $1 OR email = $1
",
params = list(username)
)
# Check if user exists and is active
if(nrow(user_data) == 0) {
# Log failed attempt
pool::dbExecute(
db_pool,
"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,
jsonlite::toJSON(list(reason = "user_not_found"))
)
)
return(list(success = FALSE, error = "Invalid username or password"))
}
user <- user_data[1, ]
if(!user$active) {
return(list(success = FALSE, error = "Account is disabled"))
}
# Verify password
password_valid <- verify_password(password, user$password_hash)
if(!password_valid) {
# Log failed attempt
pool::dbExecute(
db_pool,
"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,
jsonlite::toJSON(list(reason = "invalid_password"))
)
)
# Update failed login count
pool::dbExecute(
db_pool,
"
UPDATE users
SET failed_login_attempts = failed_login_attempts + 1
WHERE user_id = $1
",
params = list(user$user_id)
)
return(list(success = FALSE, error = "Invalid username or password"))
}
# Successful authentication
# Reset failed login attempts
pool::dbExecute(
db_pool,
"
UPDATE users
SET failed_login_attempts = 0,
last_login = CURRENT_TIMESTAMP
WHERE user_id = $1
",
params = list(user$user_id)
)
# Log successful login
pool::dbExecute(
db_pool,
"
INSERT INTO login_attempts (username, success, ip_address, user_id)
VALUES ($1, TRUE, $2, $3)
",
params = list(username, ip_address, user$user_id)
)
return(list(
success = TRUE,
user = list(
user_id = user$user_id,
username = user$username,
email = user$email,
role = user$role
),
message = "Authentication successful"
))
}
return(list(
register = register_user,
authenticate = authenticate_user,
validate_password = validate_password,
hash_password = hash_password,
verify_password = verify_password
))
}Session Management System
# Comprehensive session management
create_session_manager <- function(db_pool) {
# Session configuration
session_config <- list(
timeout = 3600, # 1 hour default timeout
extend_timeout = 1800, # 30 minutes extension
max_sessions = 5, # Max concurrent sessions per user
secure_cookies = TRUE,
httponly_cookies = TRUE
)
# Create new session
create_session <- function(user_id, user_agent = "", ip_address = "127.0.0.1") {
# Generate secure session ID
session_id <- uuid::UUIDgenerate()
session_token <- sodium::bin2hex(sodium::random(32)) # 32 bytes = 256 bits
# Calculate expiration time
expires_at <- Sys.time() + session_config$timeout
tryCatch({
# Clean up old sessions for this user
cleanup_user_sessions(user_id)
# Create new session record
pool::dbExecute(
db_pool,
"
INSERT INTO user_sessions (
session_id, user_id, session_token, created_at, expires_at,
last_activity, ip_address, user_agent, active
)
VALUES ($1, $2, $3, CURRENT_TIMESTAMP, $4, CURRENT_TIMESTAMP, $5, $6, TRUE)
",
params = list(session_id, user_id, session_token, expires_at, ip_address, user_agent)
)
# Log session creation
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details, ip_address)
VALUES ($1, 'session_created', $2, $3)
",
params = list(
user_id,
jsonlite::toJSON(list(session_id = session_id)),
ip_address
)
)
return(list(
success = TRUE,
session_id = session_id,
session_token = session_token,
expires_at = expires_at
))
}, error = function(e) {
return(list(success = FALSE, error = paste("Session creation failed:", e$message)))
})
}
# Validate session
validate_session <- function(session_id, session_token, extend_session = TRUE) {
if(is.null(session_id) || is.null(session_token)) {
return(list(valid = FALSE, error = "Missing session credentials"))
}
# Get session data with user information
session_data <- pool::dbGetQuery(
db_pool,
"
SELECT s.session_id, s.user_id, s.session_token, s.expires_at,
s.last_activity, s.active, s.ip_address,
u.username, u.email, u.role, u.active as user_active
FROM user_sessions s
JOIN users u ON s.user_id = u.user_id
WHERE s.session_id = $1 AND s.active = TRUE
",
params = list(session_id)
)
if(nrow(session_data) == 0) {
return(list(valid = FALSE, error = "Session not found"))
}
session <- session_data[1, ]
# Check if user is still active
if(!session$user_active) {
return(list(valid = FALSE, error = "User account is disabled"))
}
# Verify session token
if(session$session_token != session_token) {
return(list(valid = FALSE, error = "Invalid session token"))
}
# Check expiration
if(Sys.time() > session$expires_at) {
# Deactivate expired session
pool::dbExecute(
db_pool,
"UPDATE user_sessions SET active = FALSE WHERE session_id = $1",
params = list(session_id)
)
return(list(valid = FALSE, error = "Session expired"))
}
# Extend session if requested and not too old
if(extend_session) {
time_since_activity <- as.numeric(difftime(Sys.time(), session$last_activity, units = "secs"))
if(time_since_activity < session_config$extend_timeout) {
new_expires_at <- Sys.time() + session_config$timeout
pool::dbExecute(
db_pool,
"
UPDATE user_sessions
SET last_activity = CURRENT_TIMESTAMP, expires_at = $2
WHERE session_id = $1
",
params = list(session_id, new_expires_at)
)
session$expires_at <- new_expires_at
}
}
return(list(
valid = TRUE,
user = list(
user_id = session$user_id,
username = session$username,
email = session$email,
role = session$role
),
session = list(
session_id = session$session_id,
expires_at = session$expires_at,
last_activity = session$last_activity
)
))
}
# Destroy session
destroy_session <- function(session_id, user_id = NULL) {
tryCatch({
# Deactivate session
result <- pool::dbExecute(
db_pool,
"
UPDATE user_sessions
SET active = FALSE, ended_at = CURRENT_TIMESTAMP
WHERE session_id = $1
",
params = list(session_id)
)
# Log session destruction
if(!is.null(user_id)) {
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'session_destroyed', $2)
",
params = list(
user_id,
jsonlite::toJSON(list(session_id = session_id))
)
)
}
return(list(success = TRUE, message = "Session destroyed"))
}, error = function(e) {
return(list(success = FALSE, error = paste("Failed to destroy session:", e$message)))
})
}
# Clean up expired sessions
cleanup_expired_sessions <- function() {
tryCatch({
result <- pool::dbExecute(
db_pool,
"
UPDATE user_sessions
SET active = FALSE, ended_at = CURRENT_TIMESTAMP
WHERE active = TRUE AND expires_at < CURRENT_TIMESTAMP
"
)
cat("Cleaned up", result, "expired sessions\n")
return(result)
}, error = function(e) {
cat("Session cleanup error:", e$message, "\n")
return(0)
})
}
# Clean up old sessions for a specific user
cleanup_user_sessions <- function(user_id) {
# Get user's active sessions
active_sessions <- pool::dbGetQuery(
db_pool,
"
SELECT session_id, created_at
FROM user_sessions
WHERE user_id = $1 AND active = TRUE
ORDER BY created_at DESC
",
params = list(user_id)
)
# If user has too many sessions, deactivate oldest ones
if(nrow(active_sessions) >= session_config$max_sessions) {
sessions_to_remove <- active_sessions[(session_config$max_sessions):nrow(active_sessions), ]
for(i in 1:nrow(sessions_to_remove)) {
pool::dbExecute(
db_pool,
"
UPDATE user_sessions
SET active = FALSE, ended_at = CURRENT_TIMESTAMP
WHERE session_id = $1
",
params = list(sessions_to_remove$session_id[i])
)
}
}
}
# Get user's active sessions
get_user_sessions <- function(user_id) {
sessions <- pool::dbGetQuery(
db_pool,
"
SELECT session_id, created_at, last_activity, expires_at,
ip_address, user_agent
FROM user_sessions
WHERE user_id = $1 AND active = TRUE
ORDER BY last_activity DESC
",
params = list(user_id)
)
return(sessions)
}
return(list(
create = create_session,
validate = validate_session,
destroy = destroy_session,
cleanup_expired = cleanup_expired_sessions,
cleanup_user = cleanup_user_sessions,
get_user_sessions = get_user_sessions
))
}Role-Based Access Control
# Comprehensive role-based access control system
create_rbac_system <- function(db_pool) {
# Permission definitions
permissions <- list(
# Data permissions
"data.view" = "Can view data",
"data.create" = "Can create new data",
"data.edit" = "Can edit existing data",
"data.delete" = "Can delete data",
"data.export" = "Can export data",
# User management permissions
"users.view" = "Can view user list",
"users.create" = "Can create new users",
"users.edit" = "Can edit user details",
"users.delete" = "Can delete users",
"users.manage_roles" = "Can assign roles to users",
# System permissions
"system.admin" = "Full system administration",
"system.logs" = "Can view system logs",
"system.settings" = "Can modify system settings",
"system.backup" = "Can create system backups",
# Analysis permissions
"analysis.basic" = "Can perform basic analysis",
"analysis.advanced" = "Can perform advanced analysis",
"analysis.share" = "Can share analysis results",
# Report permissions
"reports.view" = "Can view reports",
"reports.create" = "Can create reports",
"reports.schedule" = "Can schedule reports"
)
# Default role configurations
default_roles <- list(
"viewer" = list(
name = "Viewer",
description = "Read-only access to data and reports",
permissions = c("data.view", "reports.view", "analysis.basic")
),
"user" = list(
name = "Standard User",
description = "Standard user with data access and basic analysis",
permissions = c("data.view", "data.create", "data.edit", "data.export",
"reports.view", "reports.create", "analysis.basic", "analysis.share")
),
"analyst" = list(
name = "Data Analyst",
description = "Advanced analytical capabilities",
permissions = c("data.view", "data.create", "data.edit", "data.export",
"reports.view", "reports.create", "reports.schedule",
"analysis.basic", "analysis.advanced", "analysis.share")
),
"admin" = list(
name = "Administrator",
description = "Full system access",
permissions = names(permissions)
)
)
# Initialize RBAC system
initialize_rbac <- function() {
tryCatch({
# Create roles table if it doesn't exist
pool::dbExecute(db_pool, "
CREATE TABLE IF NOT EXISTS roles (
role_id SERIAL PRIMARY KEY,
role_name VARCHAR(50) UNIQUE NOT NULL,
display_name VARCHAR(100) NOT NULL,
description TEXT,
active BOOLEAN DEFAULT TRUE,
created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP
)
")
# Create permissions table
pool::dbExecute(db_pool, "
CREATE TABLE IF NOT EXISTS permissions (
permission_id SERIAL PRIMARY KEY,
permission_name VARCHAR(100) UNIQUE NOT NULL,
description TEXT,
category VARCHAR(50),
active BOOLEAN DEFAULT TRUE
)
")
# Create role-permission mapping table
pool::dbExecute(db_pool, "
CREATE TABLE IF NOT EXISTS role_permissions (
role_id INTEGER REFERENCES roles(role_id) ON DELETE CASCADE,
permission_id INTEGER REFERENCES permissions(permission_id) ON DELETE CASCADE,
granted_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
PRIMARY KEY (role_id, permission_id)
)
")
# Insert default permissions
for(perm_name in names(permissions)) {
category <- strsplit(perm_name, "\\.")[[1]][1]
pool::dbExecute(
db_pool,
"
INSERT INTO permissions (permission_name, description, category)
VALUES ($1, $2, $3)
ON CONFLICT (permission_name) DO NOTHING
",
params = list(perm_name, permissions[[perm_name]], category)
)
}
# Insert default roles
for(role_name in names(default_roles)) {
role_info <- default_roles[[role_name]]
# Insert role
role_result <- pool::dbGetQuery(
db_pool,
"
INSERT INTO roles (role_name, display_name, description)
VALUES ($1, $2, $3)
ON CONFLICT (role_name) DO UPDATE SET
display_name = EXCLUDED.display_name,
description = EXCLUDED.description
RETURNING role_id
",
params = list(role_name, role_info$name, role_info$description)
)
role_id <- role_result$role_id[1]
# Clear existing permissions for this role
pool::dbExecute(
db_pool,
"DELETE FROM role_permissions WHERE role_id = $1",
params = list(role_id)
)
# Insert role permissions
for(perm_name in role_info$permissions) {
permission_result <- pool::dbGetQuery(
db_pool,
"SELECT permission_id FROM permissions WHERE permission_name = $1",
params = list(perm_name)
)
if(nrow(permission_result) > 0) {
pool::dbExecute(
db_pool,
"
INSERT INTO role_permissions (role_id, permission_id)
VALUES ($1, $2)
ON CONFLICT DO NOTHING
",
params = list(role_id, permission_result$permission_id[1])
)
}
}
}
# Update users table to reference roles table
pool::dbExecute(db_pool, "
ALTER TABLE users
ADD COLUMN IF NOT EXISTS role_id INTEGER REFERENCES roles(role_id)
")
# Migrate existing role strings to role IDs
pool::dbExecute(db_pool, "
UPDATE users
SET role_id = r.role_id
FROM roles r
WHERE users.role = r.role_name AND users.role_id IS NULL
")
cat("RBAC system initialized successfully\n")
return(TRUE)
}, error = function(e) {
cat("RBAC initialization failed:", e$message, "\n")
return(FALSE)
})
}
# Check if user has specific permission
has_permission <- function(user_id, permission_name) {
if(is.null(user_id) || is.null(permission_name)) {
return(FALSE)
}
# Query user permissions through role
result <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as has_permission
FROM users u
JOIN roles r ON u.role_id = r.role_id
JOIN role_permissions rp ON r.role_id = rp.role_id
JOIN permissions p ON rp.permission_id = p.permission_id
WHERE u.user_id = $1
AND p.permission_name = $2
AND u.active = TRUE
AND r.active = TRUE
AND p.active = TRUE
",
params = list(user_id, permission_name)
)
return(result$has_permission[1] > 0)
}
# Get all permissions for a user
get_user_permissions <- function(user_id) {
permissions <- pool::dbGetQuery(
db_pool,
"
SELECT p.permission_name, p.description, p.category
FROM users u
JOIN roles r ON u.role_id = r.role_id
JOIN role_permissions rp ON r.role_id = rp.role_id
JOIN permissions p ON rp.permission_id = p.permission_id
WHERE u.user_id = $1
AND u.active = TRUE
AND r.active = TRUE
AND p.active = TRUE
ORDER BY p.category, p.permission_name
",
params = list(user_id)
)
return(permissions)
}
# Get user's role information
get_user_role <- function(user_id) {
role_info <- pool::dbGetQuery(
db_pool,
"
SELECT r.role_name, r.display_name, r.description
FROM users u
JOIN roles r ON u.role_id = r.role_id
WHERE u.user_id = $1
",
params = list(user_id)
)
if(nrow(role_info) == 0) {
return(NULL)
}
return(role_info[1, ])
}
# Assign role to user
assign_role <- function(user_id, role_name, assigned_by = NULL) {
tryCatch({
# Get role ID
role_result <- pool::dbGetQuery(
db_pool,
"SELECT role_id FROM roles WHERE role_name = $1 AND active = TRUE",
params = list(role_name)
)
if(nrow(role_result) == 0) {
return(list(success = FALSE, error = "Role not found"))
}
role_id <- role_result$role_id[1]
# Update user's role
pool::dbExecute(
db_pool,
"UPDATE users SET role_id = $1 WHERE user_id = $2",
params = list(role_id, user_id)
)
# Log role assignment
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'role_assigned', $2)
",
params = list(
assigned_by %||% user_id,
jsonlite::toJSON(list(
target_user_id = user_id,
new_role = role_name,
assigned_by = assigned_by
))
)
)
return(list(success = TRUE, message = "Role assigned successfully"))
}, error = function(e) {
return(list(success = FALSE, error = paste("Role assignment failed:", e$message)))
})
}
# Create authorization wrapper
require_permission <- function(permission_name, user_id) {
if(!has_permission(user_id, permission_name)) {
# Log unauthorized access attempt
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'unauthorized_access', $2)
",
params = list(
user_id,
jsonlite::toJSON(list(
required_permission = permission_name,
timestamp = Sys.time()
))
)
)
stop("Access denied: insufficient permissions")
}
return(TRUE)
}
return(list(
initialize = initialize_rbac,
has_permission = has_permission,
get_user_permissions = get_user_permissions,
get_user_role = get_user_role,
assign_role = assign_role,
require_permission = require_permission
))
}Complete Secure Shiny Application
# Complete authenticated Shiny application
create_secure_application <- function() {
# Initialize database connection
db_config <- create_database_config()
db_pool <- create_connection_pool(db_config)
# Initialize security systems
auth_system <- create_authentication_system(db_pool)
session_manager <- create_session_manager(db_pool)
rbac_system <- create_rbac_system(db_pool)
# Initialize RBAC
rbac_system$initialize()
# Authentication UI
login_ui <- function() {
div(
class = "login-container",
style = "
display: flex;
justify-content: center;
align-items: center;
min-height: 100vh;
background: linear-gradient(135deg, #667eea 0%, #764ba2 100%);
",
div(
class = "login-card",
style = "
background: white;
padding: 40px;
border-radius: 10px;
box-shadow: 0 15px 35px rgba(0,0,0,0.1);
width: 100%;
max-width: 400px;
",
div(
style = "text-align: center; margin-bottom: 30px;",
h2("Secure Application", style = "color: #333; margin-bottom: 10px;"),
p("Please sign in to continue", style = "color: #666;")
),
# Login form
div(
id = "login_form",
div(
class = "form-group",
style = "margin-bottom: 20px;",
textInput(
"login_username",
label = NULL,
placeholder = "Username or Email",
width = "100%"
)
),
div(
class = "form-group",
style = "margin-bottom: 20px;",
passwordInput(
"login_password",
label = NULL,
placeholder = "Password",
width = "100%"
)
),
div(
class = "form-group",
style = "margin-bottom: 20px;",
checkboxInput(
"remember_me",
"Remember me",
value = FALSE
)
),
actionButton(
"login_submit",
"Sign In",
class = "btn-primary",
style = "width: 100%; padding: 12px; font-size: 16px;"
),
br(), br(),
div(
style = "text-align: center;",
actionLink(
"show_register",
"Don't have an account? Sign up",
style = "color: #667eea;"
)
)
),
# Registration form (initially hidden)
div(
id = "register_form",
style = "display: none;",
div(
class = "form-group",
style = "margin-bottom: 15px;",
textInput(
"register_username",
label = NULL,
placeholder = "Username",
width = "100%"
)
),
div(
class = "form-group",
style = "margin-bottom: 15px;",
textInput(
"register_email",
label = NULL,
placeholder = "Email Address",
width = "100%"
)
),
div(
class = "form-group",
style = "margin-bottom: 15px;",
passwordInput(
"register_password",
label = NULL,
placeholder = "Password",
width = "100%"
)
),
div(
class = "form-group",
style = "margin-bottom: 15px;",
passwordInput(
"register_confirm",
label = NULL,
placeholder = "Confirm Password",
width = "100%"
)
),
div(
class = "password-requirements",
style = "font-size: 12px; color: #666; margin-bottom: 20px;",
p("Password must contain:"),
tags$ul(
tags$li("At least 8 characters"),
tags$li("One uppercase letter"),
tags$li("One lowercase letter"),
tags$li("One number"),
tags$li("One special character")
)
),
actionButton(
"register_submit",
"Create Account",
class = "btn-success",
style = "width: 100%; padding: 12px; font-size: 16px;"
),
br(), br(),
div(
style = "text-align: center;",
actionLink(
"show_login",
"Already have an account? Sign in",
style = "color: #667eea;"
)
)
),
# Status messages
div(
id = "auth_messages",
style = "margin-top: 15px;"
)
)
)
}
# Main application UI (shown after authentication)
main_app_ui <- function() {
navbarPage(
"Secure Application",
# Header with user info and logout
header = div(
class = "navbar-header",
style = "padding: 10px;",
div(
style = "float: right;",
span(
id = "user_info",
style = "margin-right: 15px; color: #fff;",
textOutput("current_user_display", inline = TRUE)
),
actionButton(
"logout",
"Logout",
class = "btn-outline-light btn-sm"
)
)
),
# Dashboard tab
tabPanel(
"Dashboard",
icon = icon("dashboard"),
fluidRow(
column(12,
h2("Welcome to your secure dashboard!"),
# User info panel
wellPanel(
h4("Your Account Information"),
verbatimTextOutput("user_details"),
h5("Your Permissions:"),
DT::dataTableOutput("user_permissions_table")
)
)
)
),
# Data Management tab (requires data permissions)
conditionalPanel(
condition = "output.has_data_permission == true",
tabPanel(
"Data Management",
icon = icon("database"),
fluidRow(
column(6,
wellPanel(
h4("Create Data"),
conditionalPanel(
condition = "output.can_create_data == true",
textInput("data_name", "Data Name:"),
textAreaInput("data_content", "Data Content:", rows = 5),
actionButton("save_data", "Save Data", class = "btn-primary")
)
)
),
column(6,
wellPanel(
h4("Your Data"),
DT::dataTableOutput("user_data_table"),
br(),
conditionalPanel(
condition = "output.can_delete_data == true",
actionButton("delete_selected", "Delete Selected",
class = "btn-danger")
)
)
)
)
)
),
# User Management tab (admin only)
conditionalPanel(
condition = "output.can_manage_users == true",
tabPanel(
"User Management",
icon = icon("users"),
fluidRow(
column(12,
wellPanel(
h4("System Users"),
DT::dataTableOutput("all_users_table"),
br(),
fluidRow(
column(4,
selectInput("role_to_assign", "Assign Role:",
choices = c("viewer", "user", "analyst", "admin"))
),
column(4,
br(),
actionButton("assign_role", "Assign Role",
class = "btn-info")
)
)
)
)
)
)
),
# Activity Log tab (requires appropriate permissions)
conditionalPanel(
condition = "output.can_view_logs == true",
tabPanel(
"Activity Log",
icon = icon("list"),
fluidRow(
column(12,
wellPanel(
h4("System Activity Log"),
fluidRow(
column(3,
dateInput("log_start_date", "Start Date:",
value = Sys.Date() - 7)
),
column(3,
dateInput("log_end_date", "End Date:",
value = Sys.Date())
),
column(3,
selectInput("log_action_filter", "Action:",
choices = c("All" = "", "login" = "login",
"logout" = "logout", "data_create" = "data_create"))
),
column(3,
br(),
actionButton("refresh_log", "Refresh", class = "btn-info")
)
),
DT::dataTableOutput("activity_log_table")
)
)
)
)
)
)
}
# Complete UI
ui <- fluidPage(
# Custom CSS
tags$head(
tags$style(HTML("
.login-container {
font-family: 'Segoe UI', Tahoma, Geneva, Verdana, sans-serif;
}
.form-control {
border-radius: 5px;
border: 1px solid #ddd;
padding: 12px;
font-size: 14px;
}
.form-control:focus {
border-color: #667eea;
box-shadow: 0 0 0 0.2rem rgba(102, 126, 234, 0.25);
}
.btn-primary {
background: linear-gradient(135deg, #667eea 0%, #764ba2 100%);
border: none;
border-radius: 5px;
}
.btn-primary:hover {
background: linear-gradient(135deg, #5a67d8 0%, #6b46c1 100%);
}
.alert {
border-radius: 5px;
margin-top: 15px;
}
")),
# JavaScript for form switching
tags$script(HTML("
$(document).on('click', '#show_register', function() {
$('#login_form').hide();
$('#register_form').show();
});
$(document).on('click', '#show_login', function() {
$('#register_form').hide();
$('#login_form').show();
});
"))
),
# Conditional UI based on authentication status
uiOutput("main_ui")
)
server <- function(input, output, session) {
# Reactive values for application state
app_state <- reactiveValues(
authenticated = FALSE,
current_user = NULL,
user_permissions = NULL,
session_id = NULL,
session_token = NULL
)
# Main UI renderer
output$main_ui <- renderUI({
if(app_state$authenticated) {
main_app_ui()
} else {
login_ui()
}
})
# Login handler
observeEvent(input$login_submit, {
req(input$login_username, input$login_password)
# Authenticate user
auth_result <- auth_system$authenticate(
username = input$login_username,
password = input$login_password,
ip_address = session$clientData$url_hostname %||% "127.0.0.1"
)
if(auth_result$success) {
# Create session
session_result <- session_manager$create(
user_id = auth_result$user$user_id,
user_agent = session$clientData$url_search %||% "",
ip_address = session$clientData$url_hostname %||% "127.0.0.1"
)
if(session_result$success) {
# Set authentication state
app_state$authenticated <- TRUE
app_state$current_user <- auth_result$user
app_state$session_id <- session_result$session_id
app_state$session_token <- session_result$session_token
# Get user permissions
app_state$user_permissions <- rbac_system$get_user_permissions(auth_result$user$user_id)
showNotification("Login successful!", type = "success")
} else {
output$auth_messages <- renderUI({
div(class = "alert alert-danger",
"Session creation failed. Please try again.")
})
}
} else {
output$auth_messages <- renderUI({
div(class = "alert alert-danger", auth_result$error)
})
}
})
# Registration handler
observeEvent(input$register_submit, {
req(input$register_username, input$register_email,
input$register_password, input$register_confirm)
# Validate password confirmation
if(input$register_password != input$register_confirm) {
output$auth_messages <- renderUI({
div(class = "alert alert-danger", "Passwords do not match")
})
return()
}
# Register user
register_result <- auth_system$register(
username = input$register_username,
email = input$register_email,
password = input$register_password,
role = "user" # Default role
)
if(register_result$success) {
output$auth_messages <- renderUI({
div(class = "alert alert-success",
"Account created successfully! Please sign in.")
})
# Switch to login form
runjs("$('#register_form').hide(); $('#login_form').show();")
} else {
output$auth_messages <- renderUI({
div(class = "alert alert-danger", register_result$error)
})
}
})
# Session validation (run periodically)
observe({
if(app_state$authenticated) {
invalidateLater(60000) # Check every minute
session_check <- session_manager$validate(
session_id = app_state$session_id,
session_token = app_state$session_token
)
if(!session_check$valid) {
# Session invalid - logout user
app_state$authenticated <- FALSE
app_state$current_user <- NULL
app_state$session_id <- NULL
app_state$session_token <- NULL
showNotification("Session expired. Please login again.",
type = "warning", duration = 10)
}
}
})
# Logout handler
observeEvent(input$logout, {
if(!is.null(app_state$session_id)) {
session_manager$destroy(
session_id = app_state$session_id,
user_id = app_state$current_user$user_id
)
}
# Reset authentication state
app_state$authenticated <- FALSE
app_state$current_user <- NULL
app_state$session_id <- NULL
app_state$session_token <- NULL
app_state$user_permissions <- NULL
showNotification("Logged out successfully", type = "success")
})
# User display
output$current_user_display <- renderText({
if(!is.null(app_state$current_user)) {
role_info <- rbac_system$get_user_role(app_state$current_user$user_id)
role_display <- if(!is.null(role_info)) role_info$display_name else "Unknown"
paste("Welcome,", app_state$current_user$username, "(", role_display, ")")
} else {
""
}
})
# User details
output$user_details <- renderPrint({
if(!is.null(app_state$current_user)) {
user <- app_state$current_user
role_info <- rbac_system$get_user_role(user$user_id)
cat("User Information:\n")
cat("================\n")
cat("Username:", user$username, "\n")
cat("Email:", user$email, "\n")
cat("Role:", if(!is.null(role_info)) role_info$display_name else "Unknown", "\n")
cat("User ID:", user$user_id, "\n")
} else {
cat("No user information available")
}
})
# User permissions table
output$user_permissions_table <- DT::renderDataTable({
if(!is.null(app_state$user_permissions)) {
DT::datatable(
app_state$user_permissions,
options = list(
pageLength = 10,
searching = TRUE,
dom = 'rtip'
),
rownames = FALSE,
colnames = c("Permission", "Description", "Category")
)
} else {
DT::datatable(
data.frame("No permissions found" = character(0)),
options = list(dom = 't')
)
}
})
# Permission checks for UI conditionals
output$has_data_permission <- reactive({
if(is.null(app_state$current_user)) return(FALSE)
rbac_system$has_permission(app_state$current_user$user_id, "data.view")
})
outputOptions(output, "has_data_permission", suspendWhenHidden = FALSE)
output$can_create_data <- reactive({
if(is.null(app_state$current_user)) return(FALSE)
rbac_system$has_permission(app_state$current_user$user_id, "data.create")
})
outputOptions(output, "can_create_data", suspendWhenHidden = FALSE)
output$can_delete_data <- reactive({
if(is.null(app_state$current_user)) return(FALSE)
rbac_system$has_permission(app_state$current_user$user_id, "data.delete")
})
outputOptions(output, "can_delete_data", suspendWhenHidden = FALSE)
output$can_manage_users <- reactive({
if(is.null(app_state$current_user)) return(FALSE)
rbac_system$has_permission(app_state$current_user$user_id, "users.view")
})
outputOptions(output, "can_manage_users", suspendWhenHidden = FALSE)
output$can_view_logs <- reactive({
if(is.null(app_state$current_user)) return(FALSE)
rbac_system$has_permission(app_state$current_user$user_id, "system.logs")
})
outputOptions(output, "can_view_logs", suspendWhenHidden = FALSE)
# Data management features
observeEvent(input$save_data, {
req(app_state$current_user, input$data_name, input$data_content)
tryCatch({
# Check permission
rbac_system$require_permission("data.create", app_state$current_user$user_id)
# Save data
pool::dbExecute(
db_pool,
"
INSERT INTO application_data (user_id, data_name, data_content, data_type)
VALUES ($1, $2, $3, 'user_created')
",
params = list(
app_state$current_user$user_id,
input$data_name,
input$data_content
)
)
showNotification("Data saved successfully!", type = "success")
# Clear form
updateTextInput(session, "data_name", value = "")
updateTextAreaInput(session, "data_content", value = "")
}, error = function(e) {
showNotification(paste("Error:", e$message), type = "error")
})
})
# User data table
output$user_data_table <- DT::renderDataTable({
if(is.null(app_state$current_user)) return(NULL)
user_data <- pool::dbGetQuery(
db_pool,
"
SELECT data_id, data_name, created_at
FROM application_data
WHERE user_id = $1
ORDER BY created_at DESC
",
params = list(app_state$current_user$user_id)
)
if(nrow(user_data) == 0) {
return(data.frame("No data found" = character(0)))
}
DT::datatable(
user_data,
options = list(pageLength = 5, dom = 'rtip'),
selection = 'single',
rownames = FALSE
)
})
# All users table (admin only)
output$all_users_table <- DT::renderDataTable({
if(is.null(app_state$current_user)) return(NULL)
# Check permission
if(!rbac_system$has_permission(app_state$current_user$user_id, "users.view")) {
return(data.frame("Access denied" = character(0)))
}
users_data <- pool::dbGetQuery(
db_pool,
"
SELECT u.user_id, u.username, u.email, r.display_name as role,
u.active, u.created_at
FROM users u
LEFT JOIN roles r ON u.role_id = r.role_id
ORDER BY u.created_at DESC
"
)
DT::datatable(
users_data,
options = list(pageLength = 10),
selection = 'single',
rownames = FALSE
)
})
# Activity log table
output$activity_log_table <- DT::renderDataTable({
if(is.null(app_state$current_user)) return(NULL)
# Check permission
if(!rbac_system$has_permission(app_state$current_user$user_id, "system.logs")) {
return(data.frame("Access denied" = character(0)))
}
log_data <- pool::dbGetQuery(
db_pool,
"
SELECT al.timestamp, u.username, al.action,
LEFT(al.details, 100) as details
FROM activity_log al
LEFT JOIN users u ON al.user_id = u.user_id
WHERE al.timestamp >= $1 AND al.timestamp <= $2
ORDER BY al.timestamp DESC
LIMIT 1000
",
params = list(
as.POSIXct(paste(input$log_start_date %||% (Sys.Date() - 7), "00:00:00")),
as.POSIXct(paste(input$log_end_date %||% Sys.Date(), "23:59:59"))
)
)
DT::datatable(
log_data,
options = list(pageLength = 15, scrollX = TRUE),
rownames = FALSE
)
})
# Role assignment
observeEvent(input$assign_role, {
req(input$all_users_table_rows_selected, input$role_to_assign)
tryCatch({
# Check permission
rbac_system$require_permission("users.manage_roles", app_state$current_user$user_id)
selected_row <- input$all_users_table_rows_selected
# Get user data to find user_id
users_data <- pool::dbGetQuery(
db_pool,
"
SELECT u.user_id, u.username
FROM users u
LEFT JOIN roles r ON u.role_id = r.role_id
ORDER BY u.created_at DESC
LIMIT 1 OFFSET $1
",
params = list(selected_row - 1)
)
if(nrow(users_data) > 0) {
assign_result <- rbac_system$assign_role(
user_id = users_data$user_id[1],
role_name = input$role_to_assign,
assigned_by = app_state$current_user$user_id
)
if(assign_result$success) {
showNotification("Role assigned successfully!", type = "success")
} else {
showNotification(assign_result$error, type = "error")
}
}
}, error = function(e) {
showNotification(paste("Error:", e$message), type = "error")
})
})
# Session cleanup on app stop
session$onSessionEnded(function() {
if(!is.null(app_state$session_id)) {
session_manager$destroy(
session_id = app_state$session_id,
user_id = app_state$current_user$user_id
)
}
# Log disconnection
if(!is.null(app_state$current_user)) {
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'session_disconnect', $2)
",
params = list(
app_state$current_user$user_id,
jsonlite::toJSON(list(
session_id = app_state$session_id,
disconnect_time = Sys.time()
))
)
)
}
})
# Periodic session cleanup
observe({
invalidateLater(600000) # Every 10 minutes
# Clean up expired sessions
session_manager$cleanup_expired()
})
}
# Cleanup function
onStop(function() {
cat("Closing database connection pool...\n")
pool::poolClose(db_pool)
})
return(list(ui = ui, server = server))
}
# Helper function
`%||%` <- function(x, y) if(is.null(x)) y else xAdvanced Security Patterns
Multi-Factor Authentication Integration
# Multi-factor authentication system
create_mfa_system <- function(db_pool) {
# MFA configuration
mfa_config <- list(
totp_window = 30, # 30 second time window
backup_codes = 10, # Number of backup codes
qr_issuer = "Secure Shiny App",
remember_device_days = 30
)
# Generate TOTP secret for user
setup_mfa <- function(user_id) {
tryCatch({
# Generate secret key
secret <- base32enc::base32encode(sodium::random(20))
# Store secret in database
pool::dbExecute(
db_pool,
"
INSERT INTO user_mfa (user_id, secret_key, enabled, created_at)
VALUES ($1, $2, FALSE, CURRENT_TIMESTAMP)
ON CONFLICT (user_id) DO UPDATE SET
secret_key = EXCLUDED.secret_key,
enabled = FALSE,
created_at = CURRENT_TIMESTAMP
",
params = list(user_id, secret)
)
# Generate backup codes
backup_codes <- replicate(mfa_config$backup_codes, {
paste0(sample(0:9, 8, replace = TRUE), collapse = "")
})
# Store backup codes (hashed)
for(code in backup_codes) {
code_hash <- digest::digest(code, algo = "sha256")
pool::dbExecute(
db_pool,
"
INSERT INTO mfa_backup_codes (user_id, code_hash, used, created_at)
VALUES ($1, $2, FALSE, CURRENT_TIMESTAMP)
",
params = list(user_id, code_hash)
)
}
# Generate QR code data
user_info <- pool::dbGetQuery(
db_pool,
"SELECT username, email FROM users WHERE user_id = $1",
params = list(user_id)
)
qr_data <- paste0(
"otpauth://totp/",
mfa_config$qr_issuer, ":", user_info$username,
"?secret=", secret,
"&issuer=", URLencode(mfa_config$qr_issuer),
"&algorithm=SHA1&digits=6&period=30"
)
return(list(
success = TRUE,
secret = secret,
qr_data = qr_data,
backup_codes = backup_codes
))
}, error = function(e) {
return(list(success = FALSE, error = e$message))
})
}
# Verify TOTP code
verify_totp <- function(user_id, code) {
# Get user's MFA secret
mfa_data <- pool::dbGetQuery(
db_pool,
"
SELECT secret_key, enabled, last_used_at
FROM user_mfa
WHERE user_id = $1
",
params = list(user_id)
)
if(nrow(mfa_data) == 0 || !mfa_data$enabled) {
return(list(valid = FALSE, error = "MFA not enabled"))
}
secret <- mfa_data$secret_key
last_used <- mfa_data$last_used_at
# Generate expected codes for current time window
current_time <- as.integer(Sys.time())
time_step <- floor(current_time / 30)
# Check current and adjacent time windows (for clock drift)
valid_codes <- c()
for(step in (time_step - 1):(time_step + 1)) {
# Generate TOTP code for this time step
time_bytes <- packBits(intToBits(step), type = "raw")
if(length(time_bytes) < 8) {
time_bytes <- c(rep(0, 8 - length(time_bytes)), time_bytes)
}
# HMAC-SHA1
hmac_result <- digest::hmac(
base32enc::base32decode(secret),
time_bytes,
algo = "sha1",
raw = TRUE
)
# Dynamic truncation
offset <- bitwAnd(hmac_result[20], 0x0f) + 1
code_bytes <- hmac_result[offset:(offset + 3)]
# Convert to integer and get 6 digits
code_int <- sum(code_bytes * c(16777216, 65536, 256, 1)) # 2^24, 2^16, 2^8, 2^0
code_int <- bitwAnd(code_int, 0x7fffffff)
totp_code <- sprintf("%06d", code_int %% 1000000)
valid_codes <- c(valid_codes, totp_code)
}
# Check if provided code matches any valid code
if(code %in% valid_codes) {
# Check for replay attack (same code used twice)
if(!is.null(last_used) &&
difftime(Sys.time(), last_used, units = "secs") < 60) {
return(list(valid = FALSE, error = "Code already used"))
}
# Update last used time
pool::dbExecute(
db_pool,
"
UPDATE user_mfa
SET last_used_at = CURRENT_TIMESTAMP
WHERE user_id = $1
",
params = list(user_id)
)
return(list(valid = TRUE))
} else {
return(list(valid = FALSE, error = "Invalid code"))
}
}
# Verify backup code
verify_backup_code <- function(user_id, code) {
code_hash <- digest::digest(code, algo = "sha256")
# Check if code exists and is not used
backup_code <- pool::dbGetQuery(
db_pool,
"
SELECT code_id FROM mfa_backup_codes
WHERE user_id = $1 AND code_hash = $2 AND used = FALSE
",
params = list(user_id, code_hash)
)
if(nrow(backup_code) == 0) {
return(list(valid = FALSE, error = "Invalid backup code"))
}
# Mark code as used
pool::dbExecute(
db_pool,
"
UPDATE mfa_backup_codes
SET used = TRUE, used_at = CURRENT_TIMESTAMP
WHERE code_id = $1
",
params = list(backup_code$code_id[1])
)
return(list(valid = TRUE))
}
# Enable MFA for user
enable_mfa <- function(user_id, verification_code) {
# Verify the code first
verification_result <- verify_totp(user_id, verification_code)
if(!verification_result$valid) {
return(list(success = FALSE, error = "Invalid verification code"))
}
# Enable MFA
pool::dbExecute(
db_pool,
"
UPDATE user_mfa
SET enabled = TRUE, enabled_at = CURRENT_TIMESTAMP
WHERE user_id = $1
",
params = list(user_id)
)
# Log MFA enablement
pool::dbExecute(
db_pool,
"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'mfa_enabled', $2)
",
params = list(
user_id,
jsonlite::toJSON(list(enabled_at = Sys.time()))
)
)
return(list(success = TRUE, message = "MFA enabled successfully"))
}
return(list(
setup = setup_mfa,
verify_totp = verify_totp,
verify_backup = verify_backup_code,
enable = enable_mfa
))
}OAuth Integration
# OAuth integration for external authentication
create_oauth_integration <- function(db_pool) {
# OAuth providers configuration
oauth_providers <- list(
google = list(
client_id = Sys.getenv("GOOGLE_CLIENT_ID"),
client_secret = Sys.getenv("GOOGLE_CLIENT_SECRET"),
auth_url = "https://accounts.google.com/o/oauth2/auth",
token_url = "https://oauth2.googleapis.com/token",
user_info_url = "https://www.googleapis.com/oauth2/v2/userinfo",
scope = "openid email profile",
redirect_uri = "http://localhost:3838/auth/google/callback"
),
microsoft = list(
client_id = Sys.getenv("MICROSOFT_CLIENT_ID"),
client_secret = Sys.getenv("MICROSOFT_CLIENT_SECRET"),
auth_url = "https://login.microsoftonline.com/common/oauth2/v2.0/authorize",
token_url = "https://login.microsoftonline.com/common/oauth2/v2.0/token",
user_info_url = "https://graph.microsoft.com/v1.0/me",
scope = "openid email profile",
redirect_uri = "http://localhost:3838/auth/microsoft/callback"
)
)
# Generate OAuth authorization URL
get_auth_url <- function(provider_name, state = NULL) {
if(!provider_name %in% names(oauth_providers)) {
stop("Unknown OAuth provider: ", provider_name)
}
provider <- oauth_providers[[provider_name]]
# Generate state parameter for CSRF protection
if(is.null(state)) {
state <- sodium::bin2hex(sodium::random(16))
}
# Build authorization URL
params <- list(
client_id = provider$client_id,
redirect_uri = provider$redirect_uri,
response_type = "code",
scope = provider$scope,
state = state
)
query_string <- paste(
names(params),
sapply(params, URLencode, reserved = TRUE),
sep = "=", collapse = "&"
)
auth_url <- paste0(provider$auth_url, "?", query_string)
return(list(
url = auth_url,
state = state
))
}
# Exchange authorization code for access token
exchange_code <- function(provider_name, code, state) {
provider <- oauth_providers[[provider_name]]
# Prepare token request
token_data <- list(
client_id = provider$client_id,
client_secret = provider$client_secret,
code = code,
grant_type = "authorization_code",
redirect_uri = provider$redirect_uri
)
# Make token request
response <- httr::POST(
provider$token_url,
body = token_data,
encode = "form"
)
if(httr::status_code(response) != 200) {
return(list(success = FALSE, error = "Token exchange failed"))
}
token_info <- httr::content(response, "parsed")
return(list(
success = TRUE,
access_token = token_info$access_token,
token_type = token_info$token_type %||% "Bearer",
expires_in = token_info$expires_in
))
}
# Get user information from OAuth provider
get_user_info <- function(provider_name, access_token) {
provider <- oauth_providers[[provider_name]]
# Make user info request
response <- httr::GET(
provider$user_info_url,
httr::add_headers(
Authorization = paste("Bearer", access_token)
)
)
if(httr::status_code(response) != 200) {
return(list(success = FALSE, error = "User info request failed"))
}
user_info <- httr::content(response, "parsed")
# Normalize user info across providers
normalized_info <- list(
provider = provider_name,
provider_user_id = user_info$id %||% user_info$sub,
email = user_info$email,
name = user_info$name,
given_name = user_info$given_name %||% user_info$first_name,
family_name = user_info$family_name %||% user_info$last_name,
picture = user_info$picture,
verified_email = user_info$verified_email %||% TRUE
)
return(list(success = TRUE, user_info = normalized_info))
}
# Link OAuth account to existing user or create new user
process_oauth_login <- function(provider_name, user_info) {
tryCatch({
# Check if OAuth account already exists
existing_oauth <- pool::dbGetQuery(
db_pool,
"
SELECT u.user_id, u.username, u.email, u.active
FROM oauth_accounts oa
JOIN users u ON oa.user_id = u.user_id
WHERE oa.provider = $1 AND oa.provider_user_id = $2
",
params = list(provider_name, user_info$provider_user_id)
)
if(nrow(existing_oauth) > 0) {
# Existing OAuth account
user <- existing_oauth[1, ]
if(!user$active) {
return(list(success = FALSE, error = "Account is disabled"))
}
# Update last login
pool::dbExecute(
db_pool,
"
UPDATE oauth_accounts
SET last_login = CURRENT_TIMESTAMP
WHERE provider = $1 AND provider_user_id = $2
",
params = list(provider_name, user_info$provider_user_id)
)
return(list(
success = TRUE,
user = list(
user_id = user$user_id,
username = user$username,
email = user$email,
role = "user" # Get from role table if needed
),
new_user = FALSE
))
}
# Check if user exists by email
existing_user <- pool::dbGetQuery(
db_pool,
"SELECT user_id, username, email, active FROM users WHERE email = $1",
params = list(user_info$email)
)
if(nrow(existing_user) > 0) {
# Link OAuth to existing user
user <- existing_user[1, ]
pool::dbExecute(
db_pool,
"
INSERT INTO oauth_accounts (
user_id, provider, provider_user_id, provider_email,
provider_name, created_at, last_login
)
VALUES ($1, $2, $3, $4, $5, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP)
",
params = list(
user$user_id,
provider_name,
user_info$provider_user_id,
user_info$email,
user_info$name
)
)
return(list(
success = TRUE,
user = list(
user_id = user$user_id,
username = user$username,
email = user$email,
role = "user"
),
new_user = FALSE
))
} else {
# Create new user
new_user_result <- pool::dbGetQuery(
db_pool,
"
INSERT INTO users (
username, email, password_hash, role, active, created_at,
oauth_only
)
VALUES ($1, $2, '', 'user', TRUE, CURRENT_TIMESTAMP, TRUE)
RETURNING user_id, username, email
",
params = list(
# Generate username from email or name
gsub("@.*", "", user_info$email),
user_info$email
)
)
new_user <- new_user_result[1, ]
# Create OAuth account record
pool::dbExecute(
db_pool,
"
INSERT INTO oauth_accounts (
user_id, provider, provider_user_id, provider_email,
provider_name, created_at, last_login
)
VALUES ($1, $2, $3, $4, $5, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP)
",
params = list(
new_user$user_id,
provider_name,
user_info$provider_user_id,
user_info$email,
user_info$name
)
)
return(list(
success = TRUE,
user = list(
user_id = new_user$user_id,
username = new_user$username,
email = new_user$email,
role = "user"
),
new_user = TRUE
))
}
}, error = function(e) {
return(list(success = FALSE, error = paste("OAuth processing failed:", e$message)))
})
}
return(list(
get_auth_url = get_auth_url,
exchange_code = exchange_code,
get_user_info = get_user_info,
process_login = process_oauth_login
))
}Common Issues and Solutions
Issue 1: Session Hijacking and Replay Attacks
Problem: Session tokens can be intercepted and reused by attackers to gain unauthorized access.
Solution:
Implement comprehensive session security measures:
# Enhanced session security
create_secure_session_system <- function(db_pool) {
# Generate cryptographically secure session tokens
generate_session_token <- function() {
# Create session with multiple components
timestamp <- as.character(as.integer(Sys.time()))
random_bytes <- sodium::bin2hex(sodium::random(32))
# Combine and hash
token_data <- paste0(timestamp, ":", random_bytes)
secure_token <- sodium::bin2hex(sodium::hash(charToRaw(token_data)))
return(secure_token)
}
# Validate session with multiple security checks
validate_secure_session <- function(session_id, token, ip_address, user_agent) {
session_data <- pool::dbGetQuery(
db_pool,
"
SELECT s.*, u.active as user_active
FROM user_sessions s
JOIN users u ON s.user_id = u.user_id
WHERE s.session_id = $1 AND s.active = TRUE
",
params = list(session_id)
)
if(nrow(session_data) == 0) {
return(list(valid = FALSE, error = "Session not found"))
}
session <- session_data[1, ]
# Token validation
if(session$session_token != token) {
return(list(valid = FALSE, error = "Invalid token"))
}
# Expiration check
if(Sys.time() > session$expires_at) {
return(list(valid = FALSE, error = "Session expired"))
}
# IP address validation (optional, can be too restrictive)
if(!is.null(session$ip_address) && session$ip_address != ip_address) {
# Log suspicious activity
pool::dbExecute(
db_pool,
"
INSERT INTO security_events (user_id, event_type, details, ip_address)
VALUES ($1, 'suspicious_ip', $2, $3)
",
params = list(
session$user_id,
jsonlite::toJSON(list(
session_ip = session$ip_address,
request_ip = ip_address
)),
ip_address
)
)
# Could optionally invalidate session or require re-authentication
# return(list(valid = FALSE, error = "IP address mismatch"))
}
# User agent validation (basic check)
if(!is.null(session$user_agent) &&
!grepl(session$user_agent, user_agent, fixed = TRUE)) {
# Log but don't block (user agents can vary)
pool::dbExecute(
db_pool,
"
INSERT INTO security_events (user_id, event_type, details)
VALUES ($1, 'user_agent_change', $2)
",
params = list(
session$user_id,
jsonlite::toJSON(list(
original_agent = session$user_agent,
new_agent = user_agent
))
)
)
}
return(list(valid = TRUE, session = session))
}
return(list(
generate_token = generate_session_token,
validate_secure = validate_secure_session
))
}Issue 2: Password Security and Storage
Problem: Weak password policies and insecure storage make accounts vulnerable to brute force and credential theft.
Solution:
Implement comprehensive password security:
# Advanced password security system
create_password_security <- function() {
# Password strength scoring
calculate_password_strength <- function(password) {
score <- 0
feedback <- c()
# Length scoring
if(nchar(password) >= 8) score <- score + 1
if(nchar(password) >= 12) score <- score + 1
if(nchar(password) >= 16) score <- score + 1
# Character variety
if(grepl("[a-z]", password)) score <- score + 1
if(grepl("[A-Z]", password)) score <- score + 1
if(grepl("[0-9]", password)) score <- score + 1
if(grepl("[^a-zA-Z0-9]", password)) score <- score + 1
# Pattern detection
if(grepl("(.)\\1{2,}", password)) {
score <- score - 1
feedback <- c(feedback, "Avoid repeated characters")
}
if(grepl("(012|123|234|345|456|567|678|789|890)", password)) {
score <- score - 1
feedback <- c(feedback, "Avoid sequential numbers")
}
if(grepl("(abc|bcd|cde|def|efg|fgh|ghi|hij|ijk|jkl|klm|lmn|nop|opq|pqr|qrs|rst|stu|tuv|uvw|vwx|wxy|xyz)", password, ignore.case = TRUE)) {
score <- score - 1
feedback <- c(feedback, "Avoid sequential letters")
}
# Common password check
common_passwords <- c(
"password", "123456", "password123", "admin", "qwerty",
"letmein", "welcome", "monkey", "1234567890"
)
if(tolower(password) %in% common_passwords) {
score <- score - 2
feedback <- c(feedback, "Password is too common")
}
# Strength classification
strength <- if(score >= 6) {
"Strong"
} else if(score >= 4) {
"Medium"
} else if(score >= 2) {
"Weak"
} else {
"Very Weak"
}
return(list(
score = max(0, score),
strength = strength,
feedback = feedback
))
}
# Secure password hashing with Argon2
hash_password_secure <- function(password) {
# Use Argon2id with high security parameters
# Note: sodium uses Argon2i, for production consider using argon2 package for Argon2id
hashed <- sodium::password_store(password)
return(hashed)
}
# Password breach checking (simplified - in production, use HaveIBeenPwned API)
check_password_breach <- function(password) {
# Calculate SHA-1 hash
sha1_hash <- digest::digest(password, algo = "sha1", serialize = FALSE)
sha1_upper <- toupper(sha1_hash)
# In production, check against HaveIBeenPwned API
# For now, return a simple check
# Check against a small local list of known breached passwords
known_breached <- c(
"5E884898DA28047151D0E56F8DC6292773603D0D6AABBDD62A11EF721D1542D8", # "password"
"7C4A8D09CA3762AF61E59520943DC26494F8941B", # "123456"
"B1B3773A05C0ED0176787A4F1574FF0075F7521E" # "qwerty"
)
is_breached <- sha1_upper %in% known_breached
return(list(
breached = is_breached,
hash = sha1_upper
))
}
return(list(
calculate_strength = calculate_password_strength,
hash_secure = hash_password_secure,
check_breach = check_password_breach
))
}Issue 3: Rate Limiting and Brute Force Protection
Problem: Attackers can attempt unlimited login attempts to guess passwords.
Solution:
Implement comprehensive rate limiting:
# Rate limiting and brute force protection
create_rate_limiter <- function(db_pool) {
# Rate limiting configuration
rate_config <- list(
max_attempts_per_minute = 5,
max_attempts_per_hour = 20,
max_attempts_per_day = 100,
lockout_duration = 900, # 15 minutes
escalating_lockout = TRUE,
ip_whitelist = c("127.0.0.1", "::1")
)
# Check rate limits
check_rate_limit <- function(identifier, identifier_type = "ip") {
current_time <- Sys.time()
# Check if IP is whitelisted
if(identifier_type == "ip" && identifier %in% rate_config$ip_whitelist) {
return(list(allowed = TRUE, reason = "whitelisted"))
}
# Get recent attempts
attempts <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as count, MAX(attempt_time) as last_attempt
FROM rate_limit_log
WHERE identifier = $1
AND identifier_type = $2
AND attempt_time > $3
",
params = list(
identifier,
identifier_type,
current_time - 60 # Last minute
)
)
# Check minute limit
if(attempts$count >= rate_config$max_attempts_per_minute) {
return(list(
allowed = FALSE,
reason = "rate_limit_minute",
retry_after = 60 - as.numeric(difftime(current_time, attempts$last_attempt, units = "secs"))
))
}
# Check hour limit
hourly_attempts <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as count
FROM rate_limit_log
WHERE identifier = $1
AND identifier_type = $2
AND attempt_time > $3
",
params = list(
identifier,
identifier_type,
current_time - 3600 # Last hour
)
)
if(hourly_attempts$count >= rate_config$max_attempts_per_hour) {
return(list(
allowed = FALSE,
reason = "rate_limit_hour",
retry_after = 3600
))
}
# Check daily limit
daily_attempts <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as count
FROM rate_limit_log
WHERE identifier = $1
AND identifier_type = $2
AND attempt_time > $3
",
params = list(
identifier,
identifier_type,
current_time - 86400 # Last 24 hours
)
)
if(daily_attempts$count >= rate_config$max_attempts_per_day) {
return(list(
allowed = FALSE,
reason = "rate_limit_day",
retry_after = 86400
))
}
return(list(allowed = TRUE))
}
# Log rate limit attempt
log_attempt <- function(identifier, identifier_type, success, action = "login") {
pool::dbExecute(
db_pool,
"
INSERT INTO rate_limit_log (
identifier, identifier_type, action, success, attempt_time
)
VALUES ($1, $2, $3, $4, CURRENT_TIMESTAMP)
",
params = list(identifier, identifier_type, action, success)
)
}
# Check account lockout
check_account_lockout <- function(username) {
current_time <- Sys.time()
# Get recent failed attempts for this account
failed_attempts <- pool::dbGetQuery(
db_pool,
"
SELECT COUNT(*) as count, MAX(attempt_time) as last_attempt
FROM login_attempts
WHERE username = $1
AND success = FALSE
AND attempt_time > $2
",
params = list(
username,
current_time - rate_config$lockout_duration
)
)
if(failed_attempts$count >= 5) { # 5 failed attempts
time_remaining <- rate_config$lockout_duration -
as.numeric(difftime(current_time, failed_attempts$last_attempt, units = "secs"))
return(list(
locked = TRUE,
time_remaining = max(0, time_remaining)
))
}
return(list(locked = FALSE))
}
return(list(
check_rate_limit = check_rate_limit,
log_attempt = log_attempt,
check_lockout = check_account_lockout
))
}Issue 4: Input Validation and Data Protection
Problem: Malicious input can lead to security vulnerabilities like SQL injection and XSS attacks.
Solution:
Implement comprehensive input validation and data protection:
# Input validation and sanitization
create_input_validator <- function() {
# Validate username format
validate_username <- function(username) {
if(!is.character(username) || length(username) != 1) {
return(list(valid = FALSE, error = "Username must be a single string"))
}
# Length check
if(nchar(username) < 3 || nchar(username) > 50) {
return(list(valid = FALSE, error = "Username must be 3-50 characters"))
}
# Character restrictions
if(!grepl("^[a-zA-Z0-9_.-]+$", username)) {
return(list(valid = FALSE, error = "Username contains invalid characters"))
}
# Reserved names check
reserved_names <- c("admin", "root", "system", "null", "undefined", "api", "www")
if(tolower(username) %in% reserved_names) {
return(list(valid = FALSE, error = "Username is reserved"))
}
return(list(valid = TRUE))
}
# Validate email format
validate_email <- function(email) {
if(!is.character(email) || length(email) != 1) {
return(list(valid = FALSE, error = "Email must be a single string"))
}
# Length check
if(nchar(email) > 254) {
return(list(valid = FALSE, error = "Email is too long"))
}
# Format validation
email_pattern <- "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}$"
if(!grepl(email_pattern, email)) {
return(list(valid = FALSE, error = "Invalid email format"))
}
# Domain validation (basic)
domain <- gsub(".*@", "", email)
if(nchar(domain) > 253) {
return(list(valid = FALSE, error = "Email domain is too long"))
}
return(list(valid = TRUE))
}
# Sanitize HTML input
sanitize_html <- function(input) {
if(!is.character(input)) {
return("")
}
# Replace dangerous characters
sanitized <- input
sanitized <- gsub("<", "<", sanitized, fixed = TRUE)
sanitized <- gsub(">", ">", sanitized, fixed = TRUE)
sanitized <- gsub("\"", """, sanitized, fixed = TRUE)
sanitized <- gsub("'", "'", sanitized, fixed = TRUE)
sanitized <- gsub("&", "&", sanitized, fixed = TRUE)
return(sanitized)
}
# Validate and sanitize user input
validate_user_input <- function(input_data) {
result <- list(valid = TRUE, errors = c(), sanitized = list())
# Validate username if present
if(!is.null(input_data$username)) {
username_check <- validate_username(input_data$username)
if(!username_check$valid) {
result$valid <- FALSE
result$errors <- c(result$errors, paste("Username:", username_check$error))
} else {
result$sanitized$username <- trimws(input_data$username)
}
}
# Validate email if present
if(!is.null(input_data$email)) {
email_check <- validate_email(input_data$email)
if(!email_check$valid) {
result$valid <- FALSE
result$errors <- c(result$errors, paste("Email:", email_check$error))
} else {
result$sanitized$email <- trimws(tolower(input_data$email))
}
}
# Sanitize other text inputs
text_fields <- c("first_name", "last_name", "company", "description")
for(field in text_fields) {
if(!is.null(input_data[[field]])) {
sanitized_value <- sanitize_html(trimws(input_data[[field]]))
# Length check for text fields
if(nchar(sanitized_value) > 255) {
result$valid <- FALSE
result$errors <- c(result$errors, paste(field, "is too long (max 255 characters)"))
} else {
result$sanitized[[field]] <- sanitized_value
}
}
}
return(result)
}
return(list(
validate_username = validate_username,
validate_email = validate_email,
sanitize_html = sanitize_html,
validate_user_input = validate_user_input
))
}Security Monitoring and Incident Response
Security Event Logging
# Comprehensive security logging system
create_security_logger <- function(db_pool) {
# Security event types
event_types <- list(
LOGIN_SUCCESS = "login_success",
LOGIN_FAILURE = "login_failure",
LOGOUT = "logout",
PASSWORD_CHANGE = "password_change",
ACCOUNT_LOCKED = "account_locked",
PERMISSION_DENIED = "permission_denied",
SUSPICIOUS_ACTIVITY = "suspicious_activity",
SESSION_HIJACK_ATTEMPT = "session_hijack_attempt",
RATE_LIMIT_EXCEEDED = "rate_limit_exceeded",
MFA_ENABLED = "mfa_enabled",
MFA_DISABLED = "mfa_disabled",
ADMIN_ACTION = "admin_action",
DATA_ACCESS = "data_access",
SECURITY_VIOLATION = "security_violation"
)
# Log security event
log_security_event <- function(event_type, user_id = NULL, details = NULL,
ip_address = NULL, user_agent = NULL, severity = "INFO") {
tryCatch({
# Prepare event details
event_details <- if(is.null(details)) {
jsonlite::toJSON(list())
} else if(is.character(details)) {
details
} else {
jsonlite::toJSON(details)
}
# Insert security event
pool::dbExecute(
db_pool,
"
INSERT INTO security_events (
event_type, user_id, event_details, ip_address, user_agent,
severity, timestamp
)
VALUES ($1, $2, $3, $4, $5, $6, CURRENT_TIMESTAMP)
",
params = list(
event_type, user_id, event_details,
ip_address, user_agent, severity
)
)
# Console logging for immediate monitoring
cat(sprintf("[%s] SECURITY EVENT: %s - User: %s - IP: %s - Details: %s\n",
format(Sys.time(), "%Y-%m-%d %H:%M:%S"),
event_type,
user_id %||% "N/A",
ip_address %||% "N/A",
substr(event_details, 1, 100)))
# Check if this is a high-severity event that requires immediate attention
if(severity %in% c("ERROR", "CRITICAL")) {
alert_security_team(event_type, user_id, event_details, severity)
}
return(TRUE)
}, error = function(e) {
cat("Security logging error:", e$message, "\n")
return(FALSE)
})
}
# Alert security team for critical events
alert_security_team <- function(event_type, user_id, details, severity) {
# In production, this would send alerts via email, Slack, or monitoring systems
cat("🚨 SECURITY ALERT:", severity, "-", event_type, "\n")
cat("User ID:", user_id %||% "Unknown", "\n")
cat("Details:", substr(details, 1, 200), "\n")
cat("Time:", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n\n")
# Log the alert itself
pool::dbExecute(
db_pool,
"
INSERT INTO security_alerts (
event_type, user_id, alert_details, severity, alert_time, status
)
VALUES ($1, $2, $3, $4, CURRENT_TIMESTAMP, 'NEW')
",
params = list(event_type, user_id, details, severity)
)
}
# Generate security report
generate_security_report <- function(start_date, end_date, event_types = NULL) {
base_query <- "
SELECT
event_type,
severity,
COUNT(*) as event_count,
COUNT(DISTINCT user_id) as unique_users,
COUNT(DISTINCT ip_address) as unique_ips,
MIN(timestamp) as first_occurrence,
MAX(timestamp) as last_occurrence
FROM security_events
WHERE timestamp >= $1 AND timestamp <= $2
"
params <- list(start_date, end_date)
if(!is.null(event_types)) {
placeholders <- paste(rep("$", length(event_types)),
seq(3, 2 + length(event_types)),
sep = "", collapse = ",")
base_query <- paste0(base_query, " AND event_type IN (", placeholders, ")")
params <- c(params, as.list(event_types))
}
base_query <- paste0(base_query, " GROUP BY event_type, severity ORDER BY event_count DESC")
report_data <- pool::dbGetQuery(db_pool, base_query, params = params)
return(report_data)
}
# Detect anomalous patterns
detect_security_anomalies <- function() {
current_time <- Sys.time()
one_hour_ago <- current_time - 3600
anomalies <- list()
# Check for unusual login patterns
login_patterns <- pool::dbGetQuery(
db_pool,
"
SELECT ip_address, COUNT(*) as attempt_count,
COUNT(DISTINCT user_id) as user_count
FROM security_events
WHERE event_type = 'login_failure'
AND timestamp > $1
GROUP BY ip_address
HAVING COUNT(*) > 10
ORDER BY attempt_count DESC
",
params = list(one_hour_ago)
)
if(nrow(login_patterns) > 0) {
anomalies$suspicious_login_patterns <- login_patterns
}
# Check for privilege escalation attempts
privilege_attempts <- pool::dbGetQuery(
db_pool,
"
SELECT user_id, COUNT(*) as denial_count
FROM security_events
WHERE event_type = 'permission_denied'
AND timestamp > $1
GROUP BY user_id
HAVING COUNT(*) > 5
ORDER BY denial_count DESC
",
params = list(one_hour_ago)
)
if(nrow(privilege_attempts) > 0) {
anomalies$privilege_escalation_attempts <- privilege_attempts
}
# Check for session hijacking indicators
session_anomalies <- pool::dbGetQuery(
db_pool,
"
SELECT user_id, COUNT(DISTINCT ip_address) as ip_count
FROM user_sessions
WHERE created_at > $1 AND active = TRUE
GROUP BY user_id
HAVING COUNT(DISTINCT ip_address) > 3
",
params = list(one_hour_ago)
)
if(nrow(session_anomalies) > 0) {
anomalies$potential_session_hijacking <- session_anomalies
}
return(anomalies)
}
return(list(
log_event = log_security_event,
generate_report = generate_security_report,
detect_anomalies = detect_security_anomalies,
event_types = event_types
))
}Common Questions About Shiny Authentication
How do I choose between different authentication methods for my Shiny application?
The choice depends on your organizational context and security requirements:
Database Authentication is ideal for standalone applications where you control user management and need full customization of authentication workflows. It provides maximum flexibility but requires implementing all security measures yourself.
OAuth Integration works best when users already have accounts with major providers (Google, Microsoft, GitHub) and you want to reduce password management overhead. It’s excellent for applications where users expect social login options.
LDAP/Active Directory is essential for enterprise environments where user accounts are centrally managed. It provides seamless integration with existing corporate authentication systems.
Multi-Factor Authentication should be considered mandatory for applications handling sensitive data or serving high-privilege users, regardless of the primary authentication method chosen.
What are the minimum security requirements for a production Shiny application?
Essential security requirements include:
Authentication Security: Strong password policies, secure password hashing (Argon2 or bcrypt), and protection against brute force attacks through rate limiting and account lockouts.
Session Management: Cryptographically secure session tokens, appropriate session timeouts, and proper session cleanup on logout and expiration.
Transport Security: HTTPS encryption for all communications, secure cookie configuration, and protection against man-in-the-middle attacks.
Access Control: Role-based permissions system, input validation and sanitization, and protection against common web vulnerabilities (XSS, CSRF, SQL injection).
Monitoring and Auditing: Comprehensive logging of authentication events, security incidents, and user activities for compliance and security monitoring.
How can I implement single sign-on (SSO) for multiple Shiny applications?
SSO implementation involves creating a centralized authentication service that multiple applications can trust:
Token-Based SSO: Use JSON Web Tokens (JWT) issued by a central authentication server. Each Shiny application validates tokens and extracts user information without requiring separate login.
Session Sharing: Implement a shared session store (Redis or database) that multiple applications can access to validate user sessions across applications.
OAuth Provider Pattern: Create your own OAuth provider that issues access tokens for your organization’s applications, allowing standardized authentication flows.
Enterprise Integration: Integrate with existing SSO solutions like SAML, OpenID Connect, or corporate identity providers to leverage established authentication infrastructure.
The key is ensuring secure token validation, proper session management across applications, and consistent user experience throughout the authentication process.
How do I handle user permissions and role-based access control effectively?
Effective RBAC implementation requires careful planning of your permission model:
Permission Granularity: Define permissions at the appropriate level - not too broad (which creates security gaps) nor too granular (which becomes unmanageable). Focus on business functions rather than UI elements.
Role Hierarchy: Create role hierarchies that reflect your organizational structure. Users should inherit permissions from multiple roles when appropriate, and roles should be composable for flexibility.
Dynamic Permissions: Implement context-aware permissions that consider data ownership, organizational boundaries, and time-based access restrictions.
Permission Caching: Cache permission checks to avoid database queries for every operation, but ensure cache invalidation when permissions change.
Audit and Review: Regularly audit user permissions, implement approval workflows for privilege escalation, and maintain logs of permission changes for compliance requirements.
Test Your Understanding
Quiz Question 1: Authentication Security Architecture
Which combination of security measures provides the most comprehensive protection against unauthorized access in a Shiny application?
- Strong passwords + HTTPS encryption
- Multi-factor authentication + session management + rate limiting + audit logging
- OAuth integration + database encryption
- Role-based access control + input validation
- Consider defense-in-depth security principles
- Think about different attack vectors and how to protect against each
- Remember that security requires multiple complementary measures
B) Multi-factor authentication + session management + rate limiting + audit logging
Comprehensive security requires multiple complementary layers:
- Multi-factor authentication prevents access even if passwords are compromised
- Session management ensures secure user sessions and prevents session hijacking
- Rate limiting protects against brute force attacks and abuse
- Audit logging enables monitoring, incident response, and compliance
While the other options include important security measures, they don’t provide comprehensive protection against the full spectrum of potential threats. Option B represents a defense-in-depth approach that addresses authentication, session security, abuse prevention, and monitoring.
Quiz Question 2: Role-Based Access Control Implementation
Complete this code to implement a permission check that allows users to access sensitive financial data only if they have the appropriate role and the data belongs to their department:
check_financial_access <- function(user_id, department_id, rbac_system) {
# Check if user has financial data permission
has_financial_perm <- rbac_system$has_permission(user_id, "______")
# Check if user belongs to the department
user_dept <- get_user_department(user_id)
dept_match <- ______
# Return access decision
return(______ && ______)
}- What permission name would be appropriate for financial data access?
- How would you check if the user’s department matches the data’s department?
- Both conditions must be true for access to be granted
check_financial_access <- function(user_id, department_id, rbac_system) {
# Check if user has financial data permission
has_financial_perm <- rbac_system$has_permission(user_id, "financial.view")
# Check if user belongs to the department
user_dept <- get_user_department(user_id)
dept_match <- user_dept == department_id
# Return access decision
return(has_financial_perm && dept_match)
}Key concepts: - Permission-based access: Check for specific permissions rather than roles directly - Data boundary enforcement: Ensure users can only access data from their organizational unit - AND logic: Both permission and data boundary conditions must be satisfied - Context-aware security: Access decisions consider both privileges and data context
Quiz Question 3: Security Architecture Decision
Your organization is building a Shiny application that will handle sensitive customer data and needs to support 500+ concurrent users from multiple departments with different access levels. The application must integrate with existing Active Directory and support compliance auditing. What security architecture would you recommend?
- Database authentication with basic role system
- OAuth with Google/Microsoft + custom permission system
- LDAP/Active Directory integration + comprehensive RBAC + MFA + audit logging
- Simple password authentication with admin/user roles
- Consider the scale requirements (500+ users)
- Think about enterprise integration needs (Active Directory)
- Remember compliance and auditing requirements
- Consider the sensitivity of customer data
C) LDAP/Active Directory integration + comprehensive RBAC + MFA + audit logging
This architecture best addresses all requirements:
Enterprise Integration: LDAP/Active Directory integration leverages existing user management infrastructure and provides centralized authentication that scales to 500+ users efficiently.
Granular Access Control: Comprehensive RBAC enables fine-grained permissions that can handle multiple departments with different access levels while remaining manageable.
Enhanced Security: MFA is essential for sensitive customer data, providing an additional security layer beyond passwords.
Compliance Support: Comprehensive audit logging meets compliance requirements and enables security monitoring at enterprise scale.
Scalability: This architecture supports growth and can handle the complexity of a large organization with multiple departments and varying access requirements.
Conclusion
Implementing comprehensive authentication and security in Shiny applications transforms them from simple analytical tools into enterprise-grade platforms capable of handling sensitive data and serving multiple users securely. The patterns and systems you’ve learned provide the foundation for building applications that meet stringent security requirements while maintaining the analytical power and development efficiency that makes Shiny superior for data-driven applications.
The security architecture you’ve mastered combines multiple layers of protection: user authentication, session management, role-based access control, and comprehensive monitoring. This defense-in-depth approach ensures that your applications can withstand sophisticated attacks while providing auditable compliance with regulatory requirements.
These security implementations enable Shiny applications to serve as secure front-ends for enterprise data systems, handle personal and financial information responsibly, and support complex organizational access patterns. Whether you’re building departmental dashboards or company-wide business intelligence platforms, these security foundations ensure your applications meet professional standards.
Next Steps
Based on what you’ve learned in this comprehensive security tutorial, here are recommended paths for implementing and advancing your authentication systems:
Immediate Implementation Steps (Complete These First)
- Database Connectivity and SQL - Implement the complete database schema for users, sessions, roles, and security logging
- Docker Containerization for Shiny Apps - Configure secure deployment environments with HTTPS, proper firewall rules, and monitoring
- Practice Exercise: Implement the complete authentication system in a test application, including user registration, login, role management, and security monitoring
Advanced Security Features (Choose Your Priority)
For Enterprise Integration:
For Enhanced Security:
For Compliance and Auditing:
Long-term Security Goals (2-4 Weeks)
- Implement a complete enterprise authentication system with SSO integration
- Deploy production applications with comprehensive security monitoring and incident response
- Create security documentation and training materials for your organization
- Establish security review processes and regular security audits for your applications
Explore More Articles
Note
Here are more articles from the same category to help you dive deeper into the topic.
No matching items
Reuse
Citation
BibTeX citation:
@online{kassambara2025,
author = {Kassambara, Alboukadel},
title = {User {Authentication} and {Security:} {Build} {Secure}
{Shiny} {Applications}},
date = {2025-05-23},
url = {https://www.datanovia.com/learn/tools/shiny-apps/advanced-concepts/authentication.html},
langid = {en}
}
For attribution, please cite this work as:
Kassambara, Alboukadel. 2025. “User Authentication and Security:
Build Secure Shiny Applications.” May 23, 2025. https://www.datanovia.com/learn/tools/shiny-apps/advanced-concepts/authentication.html.