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
- 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
<- function(db_pool) {
create_authentication_system
# Password security configuration
<- list(
password_config 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
<- function(password) {
validate_password
<- c()
errors
if(nchar(password) < password_config$min_length) {
<- c(errors, paste("Password must be at least", password_config$min_length, "characters"))
errors
}
if(password_config$require_uppercase && !grepl("[A-Z]", password)) {
<- c(errors, "Password must contain at least one uppercase letter")
errors
}
if(password_config$require_lowercase && !grepl("[a-z]", password)) {
<- c(errors, "Password must contain at least one lowercase letter")
errors
}
if(password_config$require_numbers && !grepl("[0-9]", password)) {
<- c(errors, "Password must contain at least one number")
errors
}
if(password_config$require_special) {
<- paste0("[", gsub("([\\[\\]\\\\^$.|?*+()])", "\\\\\\1", password_config$special_chars), "]")
special_pattern if(!grepl(special_pattern, password)) {
<- c(errors, "Password must contain at least one special character")
errors
}
}
# Check for common weak passwords
<- c("password", "123456", "qwerty", "admin", "letmein")
weak_passwords if(tolower(password) %in% weak_passwords) {
<- c(errors, "Password is too common and not allowed")
errors
}
return(list(
valid = length(errors) == 0,
errors = errors
))
}
# Secure password hashing
<- function(password) {
hash_password
# Generate random salt
<- sodium::random(16) # 16 bytes = 128 bits
salt
# Hash password with salt using Argon2
<- sodium::password_store(password)
hash
return(list(
hash = hash,
salt = sodium::bin2hex(salt)
))
}
# Password verification
<- function(password, stored_hash) {
verify_password
tryCatch({
# Verify using sodium's secure verification
<- sodium::password_verify(stored_hash, password)
result
return(result)
error = function(e) {
},
# Log verification error
cat("Password verification error:", e$message, "\n")
return(FALSE)
})
}
# User registration
<- function(username, email, password, role = "user") {
register_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
<- validate_password(password)
password_check if(!password_check$valid) {
return(list(success = FALSE, error = paste(password_check$errors, collapse = "; ")))
}
# Check if user already exists
<- pool::dbGetQuery(
existing_user
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
<- hash_password(password)
password_data
tryCatch({
# Insert new user
<- pool::dbGetQuery(
result
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
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details, ip_address)
VALUES ($1, 'user_registration', $2, $3)
",
params = list(
$user_id,
result::toJSON(list(username = username, role = role)),
jsonlite"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
<- function(username, password, ip_address = "127.0.0.1") {
authenticate_user
# Check for account lockout
<- pool::dbGetQuery(
lockout_check
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
::dbExecute(
pool
db_pool,"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,::toJSON(list(reason = "account_locked"))
jsonlite
)
)
return(list(
success = FALSE,
error = "Account temporarily locked due to too many failed attempts",
locked = TRUE
))
}
# Get user data
<- pool::dbGetQuery(
user_data
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
::dbExecute(
pool
db_pool,"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,::toJSON(list(reason = "user_not_found"))
jsonlite
)
)
return(list(success = FALSE, error = "Invalid username or password"))
}
<- user_data[1, ]
user
if(!user$active) {
return(list(success = FALSE, error = "Account is disabled"))
}
# Verify password
<- verify_password(password, user$password_hash)
password_valid
if(!password_valid) {
# Log failed attempt
::dbExecute(
pool
db_pool,"
INSERT INTO login_attempts (username, success, ip_address, details)
VALUES ($1, FALSE, $2, $3)
",
params = list(
username,
ip_address,::toJSON(list(reason = "invalid_password"))
jsonlite
)
)
# Update failed login count
::dbExecute(
pool
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
::dbExecute(
pool
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
::dbExecute(
pool
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
<- function(db_pool) {
create_session_manager
# Session configuration
<- list(
session_config 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
<- function(user_id, user_agent = "", ip_address = "127.0.0.1") {
create_session
# Generate secure session ID
<- uuid::UUIDgenerate()
session_id <- sodium::bin2hex(sodium::random(32)) # 32 bytes = 256 bits
session_token
# Calculate expiration time
<- Sys.time() + session_config$timeout
expires_at
tryCatch({
# Clean up old sessions for this user
cleanup_user_sessions(user_id)
# Create new session record
::dbExecute(
pool
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
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details, ip_address)
VALUES ($1, 'session_created', $2, $3)
",
params = list(
user_id,::toJSON(list(session_id = session_id)),
jsonlite
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
<- function(session_id, session_token, extend_session = TRUE) {
validate_session
if(is.null(session_id) || is.null(session_token)) {
return(list(valid = FALSE, error = "Missing session credentials"))
}
# Get session data with user information
<- pool::dbGetQuery(
session_data
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_data[1, ]
session
# 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
::dbExecute(
pool
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) {
<- as.numeric(difftime(Sys.time(), session$last_activity, units = "secs"))
time_since_activity
if(time_since_activity < session_config$extend_timeout) {
<- Sys.time() + session_config$timeout
new_expires_at
::dbExecute(
pool
db_pool,"
UPDATE user_sessions
SET last_activity = CURRENT_TIMESTAMP, expires_at = $2
WHERE session_id = $1
",
params = list(session_id, new_expires_at)
)
$expires_at <- new_expires_at
session
}
}
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
<- function(session_id, user_id = NULL) {
destroy_session
tryCatch({
# Deactivate session
<- pool::dbExecute(
result
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)) {
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'session_destroyed', $2)
",
params = list(
user_id,::toJSON(list(session_id = session_id))
jsonlite
)
)
}
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
<- function() {
cleanup_expired_sessions
tryCatch({
<- pool::dbExecute(
result
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
<- function(user_id) {
cleanup_user_sessions
# Get user's active sessions
<- pool::dbGetQuery(
active_sessions
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) {
<- active_sessions[(session_config$max_sessions):nrow(active_sessions), ]
sessions_to_remove
for(i in 1:nrow(sessions_to_remove)) {
::dbExecute(
pool
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
<- function(user_id) {
get_user_sessions
<- pool::dbGetQuery(
sessions
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
<- function(db_pool) {
create_rbac_system
# Permission definitions
<- list(
permissions
# 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
<- list(
default_roles
"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
<- function() {
initialize_rbac
tryCatch({
# Create roles table if it doesn't exist
::dbExecute(db_pool, "
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
::dbExecute(db_pool, "
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
::dbExecute(db_pool, "
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)) {
<- strsplit(perm_name, "\\.")[[1]][1]
category
::dbExecute(
pool
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)) {
<- default_roles[[role_name]]
role_info
# Insert role
<- pool::dbGetQuery(
role_result
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_result$role_id[1]
role_id
# Clear existing permissions for this role
::dbExecute(
pool
db_pool,"DELETE FROM role_permissions WHERE role_id = $1",
params = list(role_id)
)
# Insert role permissions
for(perm_name in role_info$permissions) {
<- pool::dbGetQuery(
permission_result
db_pool,"SELECT permission_id FROM permissions WHERE permission_name = $1",
params = list(perm_name)
)
if(nrow(permission_result) > 0) {
::dbExecute(
pool
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
::dbExecute(db_pool, "
pool ALTER TABLE users
ADD COLUMN IF NOT EXISTS role_id INTEGER REFERENCES roles(role_id)
")
# Migrate existing role strings to role IDs
::dbExecute(db_pool, "
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
<- function(user_id, permission_name) {
has_permission
if(is.null(user_id) || is.null(permission_name)) {
return(FALSE)
}
# Query user permissions through role
<- pool::dbGetQuery(
result
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
<- function(user_id) {
get_user_permissions
<- pool::dbGetQuery(
permissions
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
<- function(user_id) {
get_user_role
<- pool::dbGetQuery(
role_info
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
<- function(user_id, role_name, assigned_by = NULL) {
assign_role
tryCatch({
# Get role ID
<- pool::dbGetQuery(
role_result
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_result$role_id[1]
role_id
# Update user's role
::dbExecute(
pool
db_pool,"UPDATE users SET role_id = $1 WHERE user_id = $2",
params = list(role_id, user_id)
)
# Log role assignment
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'role_assigned', $2)
",
params = list(
%||% user_id,
assigned_by ::toJSON(list(
jsonlitetarget_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
<- function(permission_name, user_id) {
require_permission
if(!has_permission(user_id, permission_name)) {
# Log unauthorized access attempt
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'unauthorized_access', $2)
",
params = list(
user_id,::toJSON(list(
jsonliterequired_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
<- function() {
create_secure_application
# Initialize database connection
<- create_database_config()
db_config <- create_connection_pool(db_config)
db_pool
# Initialize security systems
<- create_authentication_system(db_pool)
auth_system <- create_session_manager(db_pool)
session_manager <- create_rbac_system(db_pool)
rbac_system
# Initialize RBAC
$initialize()
rbac_system
# Authentication UI
<- function() {
login_ui
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:"),
$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")
tags
)
),
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)
<- function() {
main_app_ui
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:"),
::dataTableOutput("user_permissions_table")
DT
)
)
)
),
# 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"),
::dataTableOutput("user_data_table"),
DT
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"),
::dataTableOutput("all_users_table"),
DT
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")
)
),
::dataTableOutput("activity_log_table")
DT
)
)
)
)
)
)
}
# Complete UI
<- fluidPage(
ui
# Custom CSS
$head(
tags$style(HTML("
tags .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
$script(HTML("
tags $(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")
)
<- function(input, output, session) {
server
# Reactive values for application state
<- reactiveValues(
app_state authenticated = FALSE,
current_user = NULL,
user_permissions = NULL,
session_id = NULL,
session_token = NULL
)
# Main UI renderer
$main_ui <- renderUI({
output
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_system$authenticate(
auth_result 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_manager$create(
session_result 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
$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
app_state
# Get user permissions
$user_permissions <- rbac_system$get_user_permissions(auth_result$user$user_id)
app_state
showNotification("Login successful!", type = "success")
else {
}
$auth_messages <- renderUI({
outputdiv(class = "alert alert-danger",
"Session creation failed. Please try again.")
})
}
else {
}
$auth_messages <- renderUI({
outputdiv(class = "alert alert-danger", auth_result$error)
})
}
})
# Registration handler
observeEvent(input$register_submit, {
req(input$register_username, input$register_email,
$register_password, input$register_confirm)
input
# Validate password confirmation
if(input$register_password != input$register_confirm) {
$auth_messages <- renderUI({
outputdiv(class = "alert alert-danger", "Passwords do not match")
})
return()
}
# Register user
<- auth_system$register(
register_result username = input$register_username,
email = input$register_email,
password = input$register_password,
role = "user" # Default role
)
if(register_result$success) {
$auth_messages <- renderUI({
outputdiv(class = "alert alert-success",
"Account created successfully! Please sign in.")
})
# Switch to login form
runjs("$('#register_form').hide(); $('#login_form').show();")
else {
}
$auth_messages <- renderUI({
outputdiv(class = "alert alert-danger", register_result$error)
})
}
})
# Session validation (run periodically)
observe({
if(app_state$authenticated) {
invalidateLater(60000) # Check every minute
<- session_manager$validate(
session_check session_id = app_state$session_id,
session_token = app_state$session_token
)
if(!session_check$valid) {
# Session invalid - logout user
$authenticated <- FALSE
app_state$current_user <- NULL
app_state$session_id <- NULL
app_state$session_token <- NULL
app_state
showNotification("Session expired. Please login again.",
type = "warning", duration = 10)
}
}
})
# Logout handler
observeEvent(input$logout, {
if(!is.null(app_state$session_id)) {
$destroy(
session_managersession_id = app_state$session_id,
user_id = app_state$current_user$user_id
)
}
# Reset authentication state
$authenticated <- FALSE
app_state$current_user <- NULL
app_state$session_id <- NULL
app_state$session_token <- NULL
app_state$user_permissions <- NULL
app_state
showNotification("Logged out successfully", type = "success")
})
# User display
$current_user_display <- renderText({
output
if(!is.null(app_state$current_user)) {
<- rbac_system$get_user_role(app_state$current_user$user_id)
role_info <- if(!is.null(role_info)) role_info$display_name else "Unknown"
role_display
paste("Welcome,", app_state$current_user$username, "(", role_display, ")")
else {
} ""
}
})
# User details
$user_details <- renderPrint({
output
if(!is.null(app_state$current_user)) {
<- app_state$current_user
user <- rbac_system$get_user_role(user$user_id)
role_info
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
$user_permissions_table <- DT::renderDataTable({
output
if(!is.null(app_state$user_permissions)) {
::datatable(
DT$user_permissions,
app_stateoptions = list(
pageLength = 10,
searching = TRUE,
dom = 'rtip'
),rownames = FALSE,
colnames = c("Permission", "Description", "Category")
)
else {
}
::datatable(
DTdata.frame("No permissions found" = character(0)),
options = list(dom = 't')
)
}
})
# Permission checks for UI conditionals
$has_data_permission <- reactive({
output
if(is.null(app_state$current_user)) return(FALSE)
$has_permission(app_state$current_user$user_id, "data.view")
rbac_system
})
outputOptions(output, "has_data_permission", suspendWhenHidden = FALSE)
$can_create_data <- reactive({
output
if(is.null(app_state$current_user)) return(FALSE)
$has_permission(app_state$current_user$user_id, "data.create")
rbac_system
})
outputOptions(output, "can_create_data", suspendWhenHidden = FALSE)
$can_delete_data <- reactive({
output
if(is.null(app_state$current_user)) return(FALSE)
$has_permission(app_state$current_user$user_id, "data.delete")
rbac_system
})
outputOptions(output, "can_delete_data", suspendWhenHidden = FALSE)
$can_manage_users <- reactive({
output
if(is.null(app_state$current_user)) return(FALSE)
$has_permission(app_state$current_user$user_id, "users.view")
rbac_system
})
outputOptions(output, "can_manage_users", suspendWhenHidden = FALSE)
$can_view_logs <- reactive({
output
if(is.null(app_state$current_user)) return(FALSE)
$has_permission(app_state$current_user$user_id, "system.logs")
rbac_system
})
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
$require_permission("data.create", app_state$current_user$user_id)
rbac_system
# Save data
::dbExecute(
pool
db_pool,"
INSERT INTO application_data (user_id, data_name, data_content, data_type)
VALUES ($1, $2, $3, 'user_created')
",
params = list(
$current_user$user_id,
app_state$data_name,
input$data_content
input
)
)
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
$user_data_table <- DT::renderDataTable({
output
if(is.null(app_state$current_user)) return(NULL)
<- pool::dbGetQuery(
user_data
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)))
}
::datatable(
DT
user_data,options = list(pageLength = 5, dom = 'rtip'),
selection = 'single',
rownames = FALSE
)
})
# All users table (admin only)
$all_users_table <- DT::renderDataTable({
output
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)))
}
<- pool::dbGetQuery(
users_data
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
"
)
::datatable(
DT
users_data,options = list(pageLength = 10),
selection = 'single',
rownames = FALSE
)
})
# Activity log table
$activity_log_table <- DT::renderDataTable({
output
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)))
}
<- pool::dbGetQuery(
log_data
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"))
)
)
::datatable(
DT
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
$require_permission("users.manage_roles", app_state$current_user$user_id)
rbac_system
<- input$all_users_table_rows_selected
selected_row
# Get user data to find user_id
<- pool::dbGetQuery(
users_data
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) {
<- rbac_system$assign_role(
assign_result 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
$onSessionEnded(function() {
session
if(!is.null(app_state$session_id)) {
$destroy(
session_managersession_id = app_state$session_id,
user_id = app_state$current_user$user_id
)
}
# Log disconnection
if(!is.null(app_state$current_user)) {
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'session_disconnect', $2)
",
params = list(
$current_user$user_id,
app_state::toJSON(list(
jsonlitesession_id = app_state$session_id,
disconnect_time = Sys.time()
))
)
)
}
})
# Periodic session cleanup
observe({
invalidateLater(600000) # Every 10 minutes
# Clean up expired sessions
$cleanup_expired()
session_manager
})
}
# Cleanup function
onStop(function() {
cat("Closing database connection pool...\n")
::poolClose(db_pool)
pool
})
return(list(ui = ui, server = server))
}
# Helper function
`%||%` <- function(x, y) if(is.null(x)) y else x
Advanced Security Patterns
Multi-Factor Authentication Integration
# Multi-factor authentication system
<- function(db_pool) {
create_mfa_system
# MFA configuration
<- list(
mfa_config 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
<- function(user_id) {
setup_mfa
tryCatch({
# Generate secret key
<- base32enc::base32encode(sodium::random(20))
secret
# Store secret in database
::dbExecute(
pool
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
<- replicate(mfa_config$backup_codes, {
backup_codes paste0(sample(0:9, 8, replace = TRUE), collapse = "")
})
# Store backup codes (hashed)
for(code in backup_codes) {
<- digest::digest(code, algo = "sha256")
code_hash
::dbExecute(
pool
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
<- pool::dbGetQuery(
user_info
db_pool,"SELECT username, email FROM users WHERE user_id = $1",
params = list(user_id)
)
<- paste0(
qr_data "otpauth://totp/",
$qr_issuer, ":", user_info$username,
mfa_config"?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
<- function(user_id, code) {
verify_totp
# Get user's MFA secret
<- pool::dbGetQuery(
mfa_data
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"))
}
<- mfa_data$secret_key
secret <- mfa_data$last_used_at
last_used
# Generate expected codes for current time window
<- as.integer(Sys.time())
current_time <- floor(current_time / 30)
time_step
# Check current and adjacent time windows (for clock drift)
<- c()
valid_codes
for(step in (time_step - 1):(time_step + 1)) {
# Generate TOTP code for this time step
<- packBits(intToBits(step), type = "raw")
time_bytes if(length(time_bytes) < 8) {
<- c(rep(0, 8 - length(time_bytes)), time_bytes)
time_bytes
}
# HMAC-SHA1
<- digest::hmac(
hmac_result ::base32decode(secret),
base32enc
time_bytes,algo = "sha1",
raw = TRUE
)
# Dynamic truncation
<- bitwAnd(hmac_result[20], 0x0f) + 1
offset <- hmac_result[offset:(offset + 3)]
code_bytes
# Convert to integer and get 6 digits
<- sum(code_bytes * c(16777216, 65536, 256, 1)) # 2^24, 2^16, 2^8, 2^0
code_int <- bitwAnd(code_int, 0x7fffffff)
code_int <- sprintf("%06d", code_int %% 1000000)
totp_code
<- c(valid_codes, totp_code)
valid_codes
}
# 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
::dbExecute(
pool
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
<- function(user_id, code) {
verify_backup_code
<- digest::digest(code, algo = "sha256")
code_hash
# Check if code exists and is not used
<- pool::dbGetQuery(
backup_code
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
::dbExecute(
pool
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
<- function(user_id, verification_code) {
enable_mfa
# Verify the code first
<- verify_totp(user_id, verification_code)
verification_result
if(!verification_result$valid) {
return(list(success = FALSE, error = "Invalid verification code"))
}
# Enable MFA
::dbExecute(
pool
db_pool,"
UPDATE user_mfa
SET enabled = TRUE, enabled_at = CURRENT_TIMESTAMP
WHERE user_id = $1
",
params = list(user_id)
)
# Log MFA enablement
::dbExecute(
pool
db_pool,"
INSERT INTO activity_log (user_id, action, details)
VALUES ($1, 'mfa_enabled', $2)
",
params = list(
user_id,::toJSON(list(enabled_at = Sys.time()))
jsonlite
)
)
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
<- function(db_pool) {
create_oauth_integration
# OAuth providers configuration
<- list(
oauth_providers
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
<- function(provider_name, state = NULL) {
get_auth_url
if(!provider_name %in% names(oauth_providers)) {
stop("Unknown OAuth provider: ", provider_name)
}
<- oauth_providers[[provider_name]]
provider
# Generate state parameter for CSRF protection
if(is.null(state)) {
<- sodium::bin2hex(sodium::random(16))
state
}
# Build authorization URL
<- list(
params client_id = provider$client_id,
redirect_uri = provider$redirect_uri,
response_type = "code",
scope = provider$scope,
state = state
)
<- paste(
query_string names(params),
sapply(params, URLencode, reserved = TRUE),
sep = "=", collapse = "&"
)
<- paste0(provider$auth_url, "?", query_string)
auth_url
return(list(
url = auth_url,
state = state
))
}
# Exchange authorization code for access token
<- function(provider_name, code, state) {
exchange_code
<- oauth_providers[[provider_name]]
provider
# Prepare token request
<- list(
token_data client_id = provider$client_id,
client_secret = provider$client_secret,
code = code,
grant_type = "authorization_code",
redirect_uri = provider$redirect_uri
)
# Make token request
<- httr::POST(
response $token_url,
providerbody = token_data,
encode = "form"
)
if(httr::status_code(response) != 200) {
return(list(success = FALSE, error = "Token exchange failed"))
}
<- httr::content(response, "parsed")
token_info
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
<- function(provider_name, access_token) {
get_user_info
<- oauth_providers[[provider_name]]
provider
# Make user info request
<- httr::GET(
response $user_info_url,
provider::add_headers(
httrAuthorization = paste("Bearer", access_token)
)
)
if(httr::status_code(response) != 200) {
return(list(success = FALSE, error = "User info request failed"))
}
<- httr::content(response, "parsed")
user_info
# Normalize user info across providers
<- list(
normalized_info 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
<- function(provider_name, user_info) {
process_oauth_login
tryCatch({
# Check if OAuth account already exists
<- pool::dbGetQuery(
existing_oauth
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
<- existing_oauth[1, ]
user
if(!user$active) {
return(list(success = FALSE, error = "Account is disabled"))
}
# Update last login
::dbExecute(
pool
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
<- pool::dbGetQuery(
existing_user
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
<- existing_user[1, ]
user
::dbExecute(
pool
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_id,
user
provider_name,$provider_user_id,
user_info$email,
user_info$name
user_info
)
)
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
<- pool::dbGetQuery(
new_user_result
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),
$email
user_info
)
)
<- new_user_result[1, ]
new_user
# Create OAuth account record
::dbExecute(
pool
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_id,
new_user
provider_name,$provider_user_id,
user_info$email,
user_info$name
user_info
)
)
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
<- function(db_pool) {
create_secure_session_system
# Generate cryptographically secure session tokens
<- function() {
generate_session_token
# Create session with multiple components
<- as.character(as.integer(Sys.time()))
timestamp <- sodium::bin2hex(sodium::random(32))
random_bytes
# Combine and hash
<- paste0(timestamp, ":", random_bytes)
token_data <- sodium::bin2hex(sodium::hash(charToRaw(token_data)))
secure_token
return(secure_token)
}
# Validate session with multiple security checks
<- function(session_id, token, ip_address, user_agent) {
validate_secure_session
<- pool::dbGetQuery(
session_data
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_data[1, ]
session
# 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
::dbExecute(
pool
db_pool,"
INSERT INTO security_events (user_id, event_type, details, ip_address)
VALUES ($1, 'suspicious_ip', $2, $3)
",
params = list(
$user_id,
session::toJSON(list(
jsonlitesession_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)
::dbExecute(
pool
db_pool,"
INSERT INTO security_events (user_id, event_type, details)
VALUES ($1, 'user_agent_change', $2)
",
params = list(
$user_id,
session::toJSON(list(
jsonliteoriginal_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
<- function() {
create_password_security
# Password strength scoring
<- function(password) {
calculate_password_strength
<- 0
score <- c()
feedback
# 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 - 1
score <- c(feedback, "Avoid repeated characters")
feedback
}
if(grepl("(012|123|234|345|456|567|678|789|890)", password)) {
<- score - 1
score <- c(feedback, "Avoid sequential numbers")
feedback
}
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 - 1
score <- c(feedback, "Avoid sequential letters")
feedback
}
# Common password check
<- c(
common_passwords "password", "123456", "password123", "admin", "qwerty",
"letmein", "welcome", "monkey", "1234567890"
)
if(tolower(password) %in% common_passwords) {
<- score - 2
score <- c(feedback, "Password is too common")
feedback
}
# Strength classification
<- if(score >= 6) {
strength "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
<- function(password) {
hash_password_secure
# Use Argon2id with high security parameters
# Note: sodium uses Argon2i, for production consider using argon2 package for Argon2id
<- sodium::password_store(password)
hashed
return(hashed)
}
# Password breach checking (simplified - in production, use HaveIBeenPwned API)
<- function(password) {
check_password_breach
# Calculate SHA-1 hash
<- digest::digest(password, algo = "sha1", serialize = FALSE)
sha1_hash <- toupper(sha1_hash)
sha1_upper
# In production, check against HaveIBeenPwned API
# For now, return a simple check
# Check against a small local list of known breached passwords
<- c(
known_breached "5E884898DA28047151D0E56F8DC6292773603D0D6AABBDD62A11EF721D1542D8", # "password"
"7C4A8D09CA3762AF61E59520943DC26494F8941B", # "123456"
"B1B3773A05C0ED0176787A4F1574FF0075F7521E" # "qwerty"
)
<- sha1_upper %in% known_breached
is_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
<- function(db_pool) {
create_rate_limiter
# Rate limiting configuration
<- list(
rate_config 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
<- function(identifier, identifier_type = "ip") {
check_rate_limit
<- Sys.time()
current_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
<- pool::dbGetQuery(
attempts
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,- 60 # Last minute
current_time
)
)
# 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
<- pool::dbGetQuery(
hourly_attempts
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,- 3600 # Last hour
current_time
)
)
if(hourly_attempts$count >= rate_config$max_attempts_per_hour) {
return(list(
allowed = FALSE,
reason = "rate_limit_hour",
retry_after = 3600
))
}
# Check daily limit
<- pool::dbGetQuery(
daily_attempts
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,- 86400 # Last 24 hours
current_time
)
)
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
<- function(identifier, identifier_type, success, action = "login") {
log_attempt
::dbExecute(
pool
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
<- function(username) {
check_account_lockout
<- Sys.time()
current_time
# Get recent failed attempts for this account
<- pool::dbGetQuery(
failed_attempts
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,- rate_config$lockout_duration
current_time
)
)
if(failed_attempts$count >= 5) { # 5 failed attempts
<- rate_config$lockout_duration -
time_remaining 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
<- function() {
create_input_validator
# Validate username format
<- function(username) {
validate_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
<- c("admin", "root", "system", "null", "undefined", "api", "www")
reserved_names if(tolower(username) %in% reserved_names) {
return(list(valid = FALSE, error = "Username is reserved"))
}
return(list(valid = TRUE))
}
# Validate email format
<- function(email) {
validate_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
<- "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}$"
email_pattern if(!grepl(email_pattern, email)) {
return(list(valid = FALSE, error = "Invalid email format"))
}
# Domain validation (basic)
<- gsub(".*@", "", email)
domain if(nchar(domain) > 253) {
return(list(valid = FALSE, error = "Email domain is too long"))
}
return(list(valid = TRUE))
}
# Sanitize HTML input
<- function(input) {
sanitize_html
if(!is.character(input)) {
return("")
}
# Replace dangerous characters
<- 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)
sanitized
return(sanitized)
}
# Validate and sanitize user input
<- function(input_data) {
validate_user_input
<- list(valid = TRUE, errors = c(), sanitized = list())
result
# Validate username if present
if(!is.null(input_data$username)) {
<- validate_username(input_data$username)
username_check
if(!username_check$valid) {
$valid <- FALSE
result$errors <- c(result$errors, paste("Username:", username_check$error))
resultelse {
} $sanitized$username <- trimws(input_data$username)
result
}
}
# Validate email if present
if(!is.null(input_data$email)) {
<- validate_email(input_data$email)
email_check
if(!email_check$valid) {
$valid <- FALSE
result$errors <- c(result$errors, paste("Email:", email_check$error))
resultelse {
} $sanitized$email <- trimws(tolower(input_data$email))
result
}
}
# Sanitize other text inputs
<- c("first_name", "last_name", "company", "description")
text_fields
for(field in text_fields) {
if(!is.null(input_data[[field]])) {
<- sanitize_html(trimws(input_data[[field]]))
sanitized_value
# Length check for text fields
if(nchar(sanitized_value) > 255) {
$valid <- FALSE
result$errors <- c(result$errors, paste(field, "is too long (max 255 characters)"))
resultelse {
} $sanitized[[field]] <- sanitized_value
result
}
}
}
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
<- function(db_pool) {
create_security_logger
# Security event types
<- list(
event_types 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
<- function(event_type, user_id = NULL, details = NULL,
log_security_event ip_address = NULL, user_agent = NULL, severity = "INFO") {
tryCatch({
# Prepare event details
<- if(is.null(details)) {
event_details ::toJSON(list())
jsonliteelse if(is.character(details)) {
}
detailselse {
} ::toJSON(details)
jsonlite
}
# Insert security event
::dbExecute(
pool
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,%||% "N/A",
user_id %||% "N/A",
ip_address 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
<- function(event_type, user_id, details, severity) {
alert_security_team
# 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
::dbExecute(
pool
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
<- function(start_date, end_date, event_types = NULL) {
generate_security_report
<- "
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
"
<- list(start_date, end_date)
params
if(!is.null(event_types)) {
<- paste(rep("$", length(event_types)),
placeholders seq(3, 2 + length(event_types)),
sep = "", collapse = ",")
<- paste0(base_query, " AND event_type IN (", placeholders, ")")
base_query <- c(params, as.list(event_types))
params
}
<- paste0(base_query, " GROUP BY event_type, severity ORDER BY event_count DESC")
base_query
<- pool::dbGetQuery(db_pool, base_query, params = params)
report_data
return(report_data)
}
# Detect anomalous patterns
<- function() {
detect_security_anomalies
<- Sys.time()
current_time <- current_time - 3600
one_hour_ago
<- list()
anomalies
# Check for unusual login patterns
<- pool::dbGetQuery(
login_patterns
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) {
$suspicious_login_patterns <- login_patterns
anomalies
}
# Check for privilege escalation attempts
<- pool::dbGetQuery(
privilege_attempts
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) {
$privilege_escalation_attempts <- privilege_attempts
anomalies
}
# Check for session hijacking indicators
<- pool::dbGetQuery(
session_anomalies
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) {
$potential_session_hijacking <- session_anomalies
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
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.
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.
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.
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
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.
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:
<- function(user_id, department_id, rbac_system) {
check_financial_access
# Check if user has financial data permission
<- rbac_system$has_permission(user_id, "______")
has_financial_perm
# Check if user belongs to the department
<- get_user_department(user_id)
user_dept <- ______
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
<- function(user_id, department_id, rbac_system) {
check_financial_access
# Check if user has financial data permission
<- rbac_system$has_permission(user_id, "financial.view")
has_financial_perm
# Check if user belongs to the department
<- get_user_department(user_id)
user_dept <- user_dept == department_id
dept_match
# 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
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
Here are more articles from the same category to help you dive deeper into the topic.
Reuse
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}
}