User Authentication and Security: Build Secure Shiny Applications

Master Enterprise-Grade Security Implementation for Professional Applications

Learn to implement comprehensive user authentication, authorization, and security measures in Shiny applications. Master secure login systems, role-based access control, session management, and security best practices for enterprise-grade applications.

Tools
Author
Affiliation
Published

May 23, 2025

Modified

June 19, 2025

Keywords

shiny authentication, shiny security, user login shiny, shiny access control, secure shiny apps, shiny session management

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.

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

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 x


Advanced 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("<", "&lt;", sanitized, fixed = TRUE)
    sanitized <- gsub(">", "&gt;", sanitized, fixed = TRUE)
    sanitized <- gsub("\"", "&quot;", sanitized, fixed = TRUE)
    sanitized <- gsub("'", "&#x27;", sanitized, fixed = TRUE)
    sanitized <- gsub("&", "&amp;", 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

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?

  1. Strong passwords + HTTPS encryption
  2. Multi-factor authentication + session management + rate limiting + audit logging
  3. OAuth integration + database encryption
  4. 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:

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

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?

  1. Database authentication with basic role system
  2. OAuth with Google/Microsoft + custom permission system
  3. LDAP/Active Directory integration + comprehensive RBAC + MFA + audit logging
  4. 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
Back to top

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.