added on local at 2026-07-02 15:46:15
| 1 | package MODS::Login; | |
| 2 | #====================================================================== | |
| 3 | # ContactForge — login / sessions | |
| 4 | # | |
| 5 | # Cookie-based auth backed by the `users` and `user_sessions` tables | |
| 6 | # in db_schema.sql. On login we mint a UUID, drop a row in | |
| 7 | # user_sessions, and set contactforge_session=<uuid> on the response. | |
| 8 | # On every page load we look up the cookie, verify expiry/revocation, | |
| 9 | # and return a userinfo hash joined from users + the session row. | |
| 10 | # | |
| 11 | # Password hashing strategy (best available wins): | |
| 12 | # 1. Crypt::Argon2 (industry best, requires a C compiler) | |
| 13 | # 2. Digest::SHA + pbkdf2_hex with sha256, 120k iterations | |
| 14 | # — Digest::SHA is core in Perl since 5.9.3, so this always works | |
| 15 | # 3. None of the above → signup/login disabled | |
| 16 | # | |
| 17 | # Session tokens: Data::UUID if installed, else a built-in RFC4122 | |
| 18 | # v4 generator. No CPAN install required for either path. | |
| 19 | # | |
| 20 | # CPAN dependencies | |
| 21 | # REQUIRED : DBI, DBD::mysql, CGI | |
| 22 | # OPTIONAL : Crypt::Argon2 (better passwords), Data::UUID (faster) | |
| 23 | #====================================================================== | |
| 24 | ||
| 25 | use strict; | |
| 26 | use warnings; | |
| 27 | ||
| 28 | use MODS::DBConnect; | |
| 29 | use MODS::ContactForge::Config; | |
| 30 | ||
| 31 | # Optional deps — code paths fall back gracefully if missing. | |
| 32 | my $HAS_ARGON2 = eval { require Crypt::Argon2; 1 }; | |
| 33 | my $HAS_UUID = eval { require Data::UUID; 1 }; | |
| 34 | my $HAS_DIGEST = eval { require Digest::SHA; 1 }; | |
| 35 | # Older Digest::SHA (pre-5.65) doesn't export pbkdf2_hex. We don't use | |
| 36 | # it — see _hash_iter below — but we still need sha256_hex which has | |
| 37 | # been in Digest::SHA since 2003. | |
| 38 | ||
| 39 | my $db = MODS::DBConnect->new; | |
| 40 | my $config = MODS::ContactForge::Config->new; | |
| 41 | my $DB = $config->settings('database_name'); | |
| 42 | ||
| 43 | # Cached IANA timezone for the viewer on this request. Populated by | |
| 44 | # login_verify() when a session lookup succeeds; read by | |
| 45 | # MODS::DBConnect::db_connect() to SET time_zone on every fresh dbh so | |
| 46 | # NOW() / CURDATE() / DATE() / HOUR() and every TIMESTAMP column read | |
| 47 | # returns values in the viewer's local time across every reporting | |
| 48 | # page. Empty until login_verify runs (the initial lookup itself runs | |
| 49 | # in MariaDB's default tz -- harmless, no timezone-sensitive reads). | |
| 50 | our $CURRENT_USER_TZ; | |
| 51 | ||
| 52 | sub new { | |
| 53 | my ($class) = @_; | |
| 54 | return bless({}, $class); | |
| 55 | } | |
| 56 | ||
| 57 | #---------------------------------------------------------------------- | |
| 58 | # login_verify() — call at the top of every authenticated .cgi. | |
| 59 | # Reads the session cookie, looks the user up, returns: | |
| 60 | # undef — not logged in (caller should redirect to login) | |
| 61 | # $userinfo — hashref with user + session columns | |
| 62 | #---------------------------------------------------------------------- | |
| 63 | sub login_verify { | |
| 64 | my ($self) = @_; | |
| 65 | ||
| 66 | my $cookie_name = $config->settings('cookie_name'); | |
| 67 | my $token = _read_cookie($cookie_name); | |
| 68 | return undef unless $token && length($token) >= 16; | |
| 69 | return undef if $token =~ /[^a-zA-Z0-9\-]/; # CHAR(36) UUID, hex+dash only | |
| 70 | ||
| 71 | my $dbh = $db->db_connect(); | |
| 72 | return undef unless $dbh; | |
| 73 | ||
| 74 | # owner_user_id / permission_groups_id are nullable columns added in | |
| 75 | # the team-members migration. Use IFNULL so the lookup tolerates the | |
| 76 | # pre-migration state (columns absent on local dev DBs is caught by | |
| 77 | # the schema-probe in team.cgi -- here we just defensively coerce). | |
| 78 | my $sql = qq~ | |
| 79 | SELECT | |
| 80 | u.id AS user_id, | |
| 81 | u.email, | |
| 82 | u.display_name, | |
| 83 | u.plan_tier, | |
| 84 | u.account_status, | |
| 85 | u.is_admin, | |
| 86 | u.owner_user_id, | |
| 87 | u.permission_groups_id, | |
| 88 | u.two_factor_enabled, | |
| 89 | u.default_currency, | |
| 90 | u.timezone, | |
| 91 | u.last_active_at, | |
| 92 | u.session_minutes_override, | |
| 93 | u.account_state, | |
| 94 | s.id AS session_id, | |
| 95 | s.expires_at, | |
| 96 | s.revoked_at | |
| 97 | FROM ${DB}.users u | |
| 98 | JOIN ${DB}.user_sessions s ON s.user_id = u.id | |
| 99 | WHERE s.id = '$token' | |
| 100 | AND s.revoked_at IS NULL | |
| 101 | AND s.expires_at > NOW() | |
| 102 | AND u.account_status = 'active' | |
| 103 | LIMIT 1 | |
| 104 | ~; | |
| 105 | my $row = $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 106 | ||
| 107 | if (!$row || !$row->{user_id}) { | |
| 108 | $db->db_disconnect($dbh); | |
| 109 | return undef; | |
| 110 | } | |
| 111 | ||
| 112 | # Impersonation hook. If the user is an admin AND has an active row | |
| 113 | # in admin_impersonation for this session, swap the returned userinfo | |
| 114 | # to the target user. The admin's own identity is preserved in | |
| 115 | # _admin_* keys so the wrapper can render the "Acting as ..." banner | |
| 116 | # and require_admin checks can still pass while impersonating. | |
| 117 | if ($row->{is_admin}) { | |
| 118 | my $imp_check = $db->db_readwrite($dbh, qq~ | |
| 119 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 120 | WHERE table_schema='$DB' AND table_name='admin_impersonation' | |
| 121 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 122 | ||
| 123 | if ($imp_check && $imp_check->{n}) { | |
| 124 | my $sid = $row->{session_id}; | |
| 125 | $sid =~ s/[^a-zA-Z0-9\-]//g; | |
| 126 | my $imp = $db->db_readwrite($dbh, qq~ | |
| 127 | SELECT i.target_user_id, i.mode, | |
| 128 | t.email AS t_email, | |
| 129 | t.display_name AS t_display_name, | |
| 130 | t.plan_tier AS t_plan_tier, | |
| 131 | t.account_status AS t_account_status, | |
| 132 | t.default_currency AS t_default_currency, | |
| 133 | t.timezone AS t_timezone | |
| 134 | FROM ${DB}.admin_impersonation i | |
| 135 | JOIN ${DB}.users t ON t.id = i.target_user_id | |
| 136 | WHERE i.session_id = '$sid' | |
| 137 | LIMIT 1 | |
| 138 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 139 | ||
| 140 | if ($imp && $imp->{target_user_id}) { | |
| 141 | $row->{_admin_user_id} = $row->{user_id}; | |
| 142 | $row->{_admin_email} = $row->{email}; | |
| 143 | $row->{_admin_display_name} = $row->{display_name}; | |
| 144 | $row->{_admin_is_admin} = 1; | |
| 145 | $row->{_admin_mode} = $imp->{mode} || 'control'; | |
| 146 | $row->{_impersonating} = 1; | |
| 147 | ||
| 148 | $row->{user_id} = $imp->{target_user_id}; | |
| 149 | $row->{email} = $imp->{t_email}; | |
| 150 | $row->{display_name} = $imp->{t_display_name}; | |
| 151 | $row->{plan_tier} = $imp->{t_plan_tier}; | |
| 152 | $row->{account_status} = $imp->{t_account_status}; | |
| 153 | $row->{default_currency} = $imp->{t_default_currency}; | |
| 154 | $row->{timezone} = $imp->{t_timezone}; | |
| 155 | $row->{is_admin} = 0; # target user's role, not the admin's | |
| 156 | } | |
| 157 | } | |
| 158 | } | |
| 159 | ||
| 160 | # === Sliding-session idle check + maintenance lockdown === | |
| 161 | # Real session expiry is computed here, not at session-mint time. | |
| 162 | # Idle timeout = settings('session_minutes') (or per-user override). | |
| 163 | # If exceeded, delete the session row and treat as logged out. | |
| 164 | my $_idle = $row->{session_minutes_override} ? int($row->{session_minutes_override}) : int($config->settings('session_minutes') || 720); | |
| 165 | if ($row->{last_active_at}) { | |
| 166 | my $_exp = $db->db_readwrite($dbh, qq{ | |
| 167 | SELECT (TIMESTAMPDIFF(MINUTE, '$row->{last_active_at}', NOW()) > $_idle) AS expired | |
| 168 | }, $ENV{SCRIPT_NAME}, __LINE__); | |
| 169 | if ($_exp && $_exp->{expired}) { | |
| 170 | my $_sid = $row->{session_id}; $_sid =~ s/[^a-zA-Z0-9\-]//g; | |
| 171 | $db->db_readwrite($dbh, qq{DELETE FROM ${DB}.user_sessions WHERE id='$_sid'}, $ENV{SCRIPT_NAME}, __LINE__); | |
| 172 | $db->db_disconnect($dbh); | |
| 173 | return undef; | |
| 174 | } | |
| 175 | } | |
| 176 | # Maintenance lockdown: only admins pass when locked. Impersonation | |
| 177 | # bookkeeping uses _admin_is_admin to preserve the admin's role here. | |
| 178 | if ($config->settings('maintenance_locked') && !$row->{is_admin} && !$row->{_admin_is_admin}) { | |
| 179 | my $_sid = $row->{session_id}; $_sid =~ s/[^a-zA-Z0-9\-]//g; | |
| 180 | $db->db_readwrite($dbh, qq{DELETE FROM ${DB}.user_sessions WHERE id='$_sid'}, $ENV{SCRIPT_NAME}, __LINE__); | |
| 181 | $db->db_disconnect($dbh); | |
| 182 | return undef; | |
| 183 | } | |
| 184 | # Account state guard: cancelled / banned / billing_locked users | |
| 185 | # get their session killed here mid-flow. Admins impersonating a | |
| 186 | # locked user still see the account (for support / audit). | |
| 187 | if ($row->{account_state} && $row->{account_state} ne 'active' && !$row->{_admin_is_admin}) { | |
| 188 | my $_sid = $row->{session_id}; $_sid =~ s/[^a-zA-Z0-9\-]//g; | |
| 189 | $db->db_readwrite($dbh, qq{DELETE FROM ${DB}.user_sessions WHERE id='$_sid'}, $ENV{SCRIPT_NAME}, __LINE__); | |
| 190 | $db->db_disconnect($dbh); | |
| 191 | return undef; | |
| 192 | } | |
| 193 | # Bump last_active_at for the REAL user (preserves through impersonation) | |
| 194 | my $_real_uid = $row->{_admin_user_id} || $row->{user_id}; | |
| 195 | $_real_uid =~ s/[^0-9]//g; | |
| 196 | $db->db_readwrite($dbh, qq{UPDATE ${DB}.users SET last_active_at = NOW() WHERE id = $_real_uid}, $ENV{SCRIPT_NAME}, __LINE__); | |
| 197 | ||
| 198 | # Phase-3 auto-add IP to tracking_exclusions if the toggle is on. | |
| 199 | _phase3_autoadd_tracking_ip($db, $dbh, $DB, $config, $row); | |
| 200 | ||
| 201 | $db->db_disconnect($dbh); | |
| 202 | ||
| 203 | # Cache the viewer's timezone so every subsequent $db->db_connect() | |
| 204 | # on this request applies SET time_zone automatically. Impersonation | |
| 205 | # already swapped $row->{timezone} to the target user's value above, | |
| 206 | # so an admin browsing AS a rep sees the rep's local time -- | |
| 207 | # which is the right behavior because they're inspecting that | |
| 208 | # rep's reports. | |
| 209 | $CURRENT_USER_TZ = $row->{timezone} || 'UTC'; | |
| 210 | ||
| 211 | return $row; | |
| 212 | } | |
| 213 | ||
| 214 | #---------------------------------------------------------------------- | |
| 215 | # login_exec($email, $password) — verify creds, mint session. | |
| 216 | # Returns ($userinfo, $session_token) on success, () on failure. | |
| 217 | # Caller is responsible for sending Set-Cookie before any other output. | |
| 218 | #---------------------------------------------------------------------- | |
| 219 | sub login_exec { | |
| 220 | my ($self, $email, $password) = @_; | |
| 221 | return () unless $email && $password; | |
| 222 | ||
| 223 | my $dbh = $db->db_connect(); | |
| 224 | return () unless $dbh; | |
| 225 | ||
| 226 | my $safe_email = $email; | |
| 227 | $safe_email =~ s/[\\']/\\$&/g; | |
| 228 | ||
| 229 | my $sql = qq~ | |
| 230 | SELECT id, email, password_hash, account_status, account_state | |
| 231 | FROM ${DB}.users | |
| 232 | WHERE email = '$safe_email' | |
| 233 | LIMIT 1 | |
| 234 | ~; | |
| 235 | my $user = $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 236 | ||
| 237 | if (!$user || !$user->{id} || $user->{account_status} ne 'active') { | |
| 238 | $db->db_disconnect($dbh); | |
| 239 | return (); | |
| 240 | } | |
| 241 | if ($user->{account_state} && $user->{account_state} ne 'active') { | |
| 242 | $db->db_disconnect($dbh); | |
| 243 | return (); | |
| 244 | } | |
| 245 | if (_phase3_is_blocked($db, $dbh, $DB, $ENV{REMOTE_ADDR}, $email)) { | |
| 246 | $db->db_disconnect($dbh); | |
| 247 | return (); | |
| 248 | } | |
| 249 | ||
| 250 | if (!_verify_password($password, $user->{password_hash})) { | |
| 251 | $db->db_disconnect($dbh); | |
| 252 | return (); | |
| 253 | } | |
| 254 | ||
| 255 | # Mint session. | |
| 256 | # expires_at is a 10-year safety net only -- real expiry is the | |
| 257 | # sliding idle check in login_verify against users.last_active_at. | |
| 258 | my $token = _new_uuid(); | |
| 259 | my $minutes = 5256000; # ~10 years | |
| 260 | my $ua = ($ENV{HTTP_USER_AGENT} || ''); | |
| 261 | $ua =~ s/[\\']/\\$&/g; | |
| 262 | $ua = substr($ua, 0, 255); | |
| 263 | ||
| 264 | # Pack the client IP in Perl rather than relying on INET6_ATON / INET_ATON, | |
| 265 | # which differ across MariaDB versions (INET6_ATON only exists in 10.0+). | |
| 266 | # ip_address is VARBINARY(16) so we hex-encode and use UNHEX(), or NULL if | |
| 267 | # we can't parse it. | |
| 268 | my $ip_clause = 'NULL'; | |
| 269 | if (my $ip = $ENV{REMOTE_ADDR}) { | |
| 270 | my $packed; | |
| 271 | if (eval { require Socket; 1 } && defined &Socket::inet_pton) { | |
| 272 | $packed = eval { Socket::inet_pton(Socket::AF_INET(), $ip) } | |
| 273 | || eval { Socket::inet_pton(Socket::AF_INET6(), $ip) }; | |
| 274 | } | |
| 275 | if ($packed) { | |
| 276 | $ip_clause = "UNHEX('" . unpack('H*', $packed) . "')"; | |
| 277 | } | |
| 278 | } | |
| 279 | ||
| 280 | my $sql_ins = qq~ | |
| 281 | INSERT INTO ${DB}.user_sessions SET | |
| 282 | id = '$token', | |
| 283 | user_id = '$user->{id}', | |
| 284 | ip_address = $ip_clause, | |
| 285 | user_agent = '$ua', | |
| 286 | issued_at = NOW(), | |
| 287 | expires_at = DATE_ADD(NOW(), INTERVAL $minutes MINUTE) | |
| 288 | ~; | |
| 289 | $db->db_readwrite($dbh, $sql_ins, $ENV{SCRIPT_NAME}, __LINE__); | |
| 290 | ||
| 291 | my $sql_login = qq~UPDATE ${DB}.users SET last_login_at = NOW(), last_active_at = NOW() WHERE id = '$user->{id}'~; | |
| 292 | $db->db_readwrite($dbh, $sql_login, $ENV{SCRIPT_NAME}, __LINE__); | |
| 293 | ||
| 294 | # Re-read the full row so the wrapper has display_name, plan_tier, etc. | |
| 295 | my $sql_full = qq~SELECT * FROM ${DB}.users WHERE id = '$user->{id}'~; | |
| 296 | my $userinfo = $db->db_readwrite($dbh, $sql_full, $ENV{SCRIPT_NAME}, __LINE__); | |
| 297 | $userinfo->{user_id} = $userinfo->{id}; | |
| 298 | $userinfo->{session_id} = $token; | |
| 299 | ||
| 300 | $db->db_disconnect($dbh); | |
| 301 | ||
| 302 | return ($userinfo, $token); | |
| 303 | } | |
| 304 | ||
| 305 | #---------------------------------------------------------------------- | |
| 306 | # signup($email, $password, $display_name, $plan_tier) — create a | |
| 307 | # user row. Returns user_id on success, undef on dup-email / failure. | |
| 308 | #---------------------------------------------------------------------- | |
| 309 | sub signup { | |
| 310 | my ($self, $email, $password, $display_name, $plan_tier) = @_; | |
| 311 | return undef unless $email && $password && length($password) >= 8; | |
| 312 | ||
| 313 | $plan_tier ||= 'free'; | |
| 314 | $display_name ||= (split /\@/, $email)[0]; | |
| 315 | ||
| 316 | my $hash = _hash_password($password); | |
| 317 | return undef unless $hash; | |
| 318 | ||
| 319 | my $dbh = $db->db_connect(); | |
| 320 | return undef unless $dbh; | |
| 321 | ||
| 322 | # --- phase4-signup-blocklist :: 2026-07-02 --- | |
| 323 | if (_phase3_is_blocked($db, $dbh, $DB, $ENV{REMOTE_ADDR}, $email)) { | |
| 324 | $db->db_disconnect($dbh); | |
| 325 | return undef; | |
| 326 | } | |
| 327 | ||
| 328 | for ($email, $hash, $display_name, $plan_tier) { s/[\\']/\\$&/g; } | |
| 329 | ||
| 330 | my $sql = qq~ | |
| 331 | INSERT INTO ${DB}.users SET | |
| 332 | email = '$email', | |
| 333 | password_hash = '$hash', | |
| 334 | display_name = '$display_name', | |
| 335 | plan_tier = '$plan_tier', | |
| 336 | account_status = 'active', | |
| 337 | created_at = NOW() | |
| 338 | ~; | |
| 339 | my $r = $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 340 | $db->db_disconnect($dbh); | |
| 341 | ||
| 342 | return $r->{mysql_insertid}; | |
| 343 | } | |
| 344 | ||
| 345 | #---------------------------------------------------------------------- | |
| 346 | # update_password($user_id, $new_plain) — replace a user's password | |
| 347 | # hash. Used by /reset_password.cgi (after token verification) and by | |
| 348 | # the admin "force-reset" action. Revokes all active sessions for the | |
| 349 | # user as a side effect -- a password change should log the attacker | |
| 350 | # out of any session they might already hold. | |
| 351 | # | |
| 352 | # Returns 1 on success, 0 on failure. | |
| 353 | #---------------------------------------------------------------------- | |
| 354 | sub update_password { | |
| 355 | my ($self, $user_id, $new_plain) = @_; | |
| 356 | $user_id =~ s/[^0-9]//g if defined $user_id; | |
| 357 | return 0 unless $user_id; | |
| 358 | return 0 unless defined $new_plain && length($new_plain) >= 8; | |
| 359 | ||
| 360 | my $hash = _hash_password($new_plain); | |
| 361 | return 0 unless $hash; | |
| 362 | $hash =~ s/[\\']/\\$&/g; | |
| 363 | ||
| 364 | my $dbh = $db->db_connect(); | |
| 365 | return 0 unless $dbh; | |
| 366 | ||
| 367 | $db->db_readwrite($dbh, qq~ | |
| 368 | UPDATE ${DB}.users | |
| 369 | SET password_hash='$hash' | |
| 370 | WHERE id='$user_id' | |
| 371 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 372 | ||
| 373 | # Revoke every active session for this user. Forces a re-login on | |
| 374 | # any device the legitimate owner had open, but also kicks an | |
| 375 | # attacker out the moment we rotate the credential. | |
| 376 | $db->db_readwrite($dbh, qq~ | |
| 377 | UPDATE ${DB}.user_sessions | |
| 378 | SET revoked_at=NOW() | |
| 379 | WHERE user_id='$user_id' AND revoked_at IS NULL | |
| 380 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 381 | ||
| 382 | $db->db_disconnect($dbh); | |
| 383 | return 1; | |
| 384 | } | |
| 385 | ||
| 386 | #---------------------------------------------------------------------- | |
| 387 | # logout_exec($userinfo_or_token) — revoke the session. | |
| 388 | #---------------------------------------------------------------------- | |
| 389 | sub logout_exec { | |
| 390 | my ($self, $userinfo) = @_; | |
| 391 | my $token = ref($userinfo) ? $userinfo->{session_id} : $userinfo; | |
| 392 | return unless $token; | |
| 393 | return if $token =~ /[^a-zA-Z0-9\-]/; | |
| 394 | ||
| 395 | my $dbh = $db->db_connect(); | |
| 396 | return unless $dbh; | |
| 397 | my $sql = qq~UPDATE ${DB}.user_sessions SET revoked_at = NOW() WHERE id = '$token'~; | |
| 398 | $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 399 | $db->db_disconnect($dbh); | |
| 400 | return 1; | |
| 401 | } | |
| 402 | ||
| 403 | #---------------------------------------------------------------------- | |
| 404 | # Cookie header helpers — print these BEFORE any Content-Type / body. | |
| 405 | #---------------------------------------------------------------------- | |
| 406 | sub set_cookie_header { | |
| 407 | my ($self, $token) = @_; | |
| 408 | my $name = $config->settings('cookie_name'); | |
| 409 | my $minutes = 5256000; # 10y; server controls real expiry | |
| 410 | # session_minutes_override: lift cookie Max-Age to match the server-side | |
| 411 | # expires_at when the owning user has a per-account override. | |
| 412 | if ($token) { | |
| 413 | my $cdbh = $db->db_connect(); | |
| 414 | if ($cdbh) { | |
| 415 | my $tk = $token; $tk =~ s/'/''/g; | |
| 416 | my $ovr = $db->db_readwrite($cdbh, qq~ | |
| 417 | SELECT u.session_minutes_override | |
| 418 | FROM ${DB}.user_sessions s | |
| 419 | JOIN ${DB}.users u ON u.id = s.user_id | |
| 420 | WHERE s.id = '$tk' LIMIT 1 | |
| 421 | ~, __FILE__, __LINE__); | |
| 422 | if ($ovr && $ovr->{session_minutes_override}) { | |
| 423 | $minutes = int($ovr->{session_minutes_override}); | |
| 424 | } | |
| 425 | $db->db_disconnect($cdbh); | |
| 426 | } | |
| 427 | } | |
| 428 | my $secure = $config->settings('secure_cookies') ? '; Secure' : ''; | |
| 429 | # Domain= (leading dot) shares the session across every subdomain | |
| 430 | # of the platform so a logged-in rep is recognized on their own | |
| 431 | # dashboard subdomain (3dshawn.contactforge.com) -- not just on the | |
| 432 | # dashboard host (contactforge.com). Empty string falls back to the | |
| 433 | # legacy host-only behavior. | |
| 434 | my $dom_v = $config->settings('cookie_domain') || ''; | |
| 435 | my $domain = length($dom_v) ? "; Domain=$dom_v" : ''; | |
| 436 | return "Set-Cookie: $name=$token; Path=/$domain; Max-Age=" . ($minutes * 60) . | |
| 437 | "; HttpOnly; SameSite=Lax$secure\n"; | |
| 438 | } | |
| 439 | ||
| 440 | sub clear_cookie_header { | |
| 441 | my ($self) = @_; | |
| 442 | my $name = $config->settings('cookie_name'); | |
| 443 | my $dom_v = $config->settings('cookie_domain') || ''; | |
| 444 | my $domain = length($dom_v) ? "; Domain=$dom_v" : ''; | |
| 445 | return "Set-Cookie: $name=; Path=/$domain; Max-Age=0; HttpOnly; SameSite=Lax\n"; | |
| 446 | } | |
| 447 | ||
| 448 | #====================================================================== | |
| 449 | # Internal helpers | |
| 450 | #====================================================================== | |
| 451 | ||
| 452 | sub _read_cookie { | |
| 453 | my ($name) = @_; | |
| 454 | my $raw = $ENV{HTTP_COOKIE} || ''; | |
| 455 | foreach my $piece (split /;\s*/, $raw) { | |
| 456 | my ($k, $v) = split /=/, $piece, 2; | |
| 457 | return $v if defined $k && $k eq $name; | |
| 458 | } | |
| 459 | return undef; | |
| 460 | } | |
| 461 | ||
| 462 | sub _new_uuid { | |
| 463 | if ($HAS_UUID) { | |
| 464 | return lc(Data::UUID->new->create_str); | |
| 465 | } | |
| 466 | # RFC4122 v4 (random) — 8-4-4-4-12 lowercase hex. | |
| 467 | my @hex = ('0'..'9','a'..'f'); | |
| 468 | my $rand = sub { join('', map { $hex[int(rand 16)] } 1..$_[0]) }; | |
| 469 | return $rand->(8) . '-' . $rand->(4) . '-4' . $rand->(3) . '-' . | |
| 470 | ((qw(8 9 a b))[int(rand 4)]) . $rand->(3) . '-' . $rand->(12); | |
| 471 | } | |
| 472 | ||
| 473 | # Stored format strings: | |
| 474 | # argon2id → "$argon2id$v=19$m=...,t=...,p=...$<salt>$<hash>" | |
| 475 | # iter-sha256 → "iter-sha256$<iter>$<salt>$<hash-hex>" (our own format) | |
| 476 | # | |
| 477 | # The iter-sha256 format is salted, iterated SHA-256. It isn't RFC-blessed | |
| 478 | # PBKDF2 but provides equivalent key-stretching protection at 100k rounds | |
| 479 | # and works on any Perl with Digest::SHA — including the very old version | |
| 480 | # this server ships, which pre-dates Digest::SHA's pbkdf2_hex export. | |
| 481 | sub _hash_password { | |
| 482 | my ($plain) = @_; | |
| 483 | return undef unless defined $plain && length $plain; | |
| 484 | ||
| 485 | if ($HAS_ARGON2) { | |
| 486 | my $salt = ''; | |
| 487 | $salt .= chr(int(rand(256))) for 1..16; | |
| 488 | return Crypt::Argon2::argon2id_pass($plain, $salt, 3, '32M', 1, 32); | |
| 489 | } | |
| 490 | ||
| 491 | if ($HAS_DIGEST) { | |
| 492 | my @c = ('a'..'z','A'..'Z','0'..'9'); | |
| 493 | my $salt = ''; | |
| 494 | $salt .= $c[int(rand 62)] for 1..16; | |
| 495 | my $iter = 100_000; | |
| 496 | my $hex = _iter_sha256($plain, $salt, $iter); | |
| 497 | return "iter-sha256\$$iter\$$salt\$$hex"; | |
| 498 | } | |
| 499 | ||
| 500 | return undef; | |
| 501 | } | |
| 502 | ||
| 503 | sub _verify_password { | |
| 504 | my ($plain, $stored) = @_; | |
| 505 | return 0 unless defined $plain && defined $stored; | |
| 506 | ||
| 507 | if ($stored =~ /^\$argon2/ && $HAS_ARGON2) { | |
| 508 | return eval { Crypt::Argon2::argon2id_verify($stored, $plain) } ? 1 : 0; | |
| 509 | } | |
| 510 | ||
| 511 | if ($stored =~ /^iter-sha256\$(\d+)\$([^\$]+)\$([0-9a-f]+)$/ && $HAS_DIGEST) { | |
| 512 | my ($iter, $salt, $hex) = ($1, $2, $3); | |
| 513 | my $computed = _iter_sha256($plain, $salt, $iter); | |
| 514 | return _ct_eq($computed, $hex); | |
| 515 | } | |
| 516 | ||
| 517 | return 0; | |
| 518 | } | |
| 519 | ||
| 520 | # Salted iterated SHA-256. Each round hashes (salt . previous-hash). The | |
| 521 | # salt is mixed into every iteration so a precomputed rainbow table for | |
| 522 | # unsalted SHA-256 is useless. 100k rounds = ~200ms per verify, which | |
| 523 | # rate-limits brute-force attempts naturally. | |
| 524 | sub _iter_sha256 { | |
| 525 | my ($password, $salt, $iter) = @_; | |
| 526 | my $hash = $password; | |
| 527 | for (1 .. $iter) { | |
| 528 | $hash = Digest::SHA::sha256_hex($salt . $hash); | |
| 529 | } | |
| 530 | return $hash; | |
| 531 | } | |
| 532 | ||
| 533 | # Constant-time string compare to avoid timing oracles on hash verify. | |
| 534 | sub _ct_eq { | |
| 535 | my ($a, $b) = @_; | |
| 536 | return 0 unless defined $a && defined $b; | |
| 537 | return 0 if length($a) != length($b); | |
| 538 | my $diff = 0; | |
| 539 | for my $i (0 .. length($a) - 1) { | |
| 540 | $diff |= ord(substr($a, $i, 1)) ^ ord(substr($b, $i, 1)); | |
| 541 | } | |
| 542 | return $diff == 0 ? 1 : 0; | |
| 543 | } | |
| 544 | ||
| 545 | # --- phase3-account-state-blocklist-guard :: 2026-07-02 --- | |
| 546 | ||
| 547 | # Phase-3 helper: auto-add caller's IP to tracking_exclusions. | |
| 548 | sub _phase3_autoadd_tracking_ip { | |
| 549 | my ($db, $dbh, $DB, $config, $row) = @_; | |
| 550 | my $ip = $ENV{REMOTE_ADDR}; | |
| 551 | return unless $ip; | |
| 552 | $ip =~ s/[^0-9a-fA-F:.]//g; | |
| 553 | return unless length $ip; | |
| 554 | ||
| 555 | my $is_admin_real = $row->{is_admin} || $row->{_admin_is_admin}; | |
| 556 | my $real_uid = $row->{_admin_user_id} || $row->{user_id}; | |
| 557 | $real_uid =~ s/[^0-9]//g if defined $real_uid; | |
| 558 | ||
| 559 | if ($is_admin_real && $config->settings('auto_add_login_ip_admin')) { | |
| 560 | # Check-then-insert (INSERT IGNORE won't dedupe -- no unique key | |
| 561 | # possible on (scope, ip, user_id) because user_id is NULL for | |
| 562 | # admin scope and MariaDB treats NULLs as distinct in unique keys). | |
| 563 | my $exists = $db->db_readwrite($dbh, qq{ | |
| 564 | SELECT id FROM ${DB}.tracking_exclusions | |
| 565 | WHERE scope='admin' AND ip='$ip' AND user_id IS NULL LIMIT 1 | |
| 566 | }, $ENV{SCRIPT_NAME}, __LINE__); | |
| 567 | if (!$exists || !$exists->{id}) { | |
| 568 | $db->db_readwrite($dbh, qq{ | |
| 569 | INSERT INTO ${DB}.tracking_exclusions | |
| 570 | (scope, user_id, ip, label, source, active) | |
| 571 | VALUES ('admin', NULL, '$ip', 'auto-added on login', 'auto_login', 1) | |
| 572 | }, $ENV{SCRIPT_NAME}, __LINE__); | |
| 573 | } | |
| 574 | } | |
| 575 | elsif (!$is_admin_real && $real_uid && $config->settings('auto_add_login_ip_user')) { | |
| 576 | my $exists = $db->db_readwrite($dbh, qq{ | |
| 577 | SELECT id FROM ${DB}.tracking_exclusions | |
| 578 | WHERE scope='user' AND ip='$ip' AND user_id=$real_uid LIMIT 1 | |
| 579 | }, $ENV{SCRIPT_NAME}, __LINE__); | |
| 580 | if (!$exists || !$exists->{id}) { | |
| 581 | $db->db_readwrite($dbh, qq{ | |
| 582 | INSERT INTO ${DB}.tracking_exclusions | |
| 583 | (scope, user_id, ip, label, source, active) | |
| 584 | VALUES ('user', $real_uid, '$ip', 'auto-added on login', 'auto_login', 1) | |
| 585 | }, $ENV{SCRIPT_NAME}, __LINE__); | |
| 586 | } | |
| 587 | } | |
| 588 | } | |
| 589 | ||
| 590 | # Phase-3 helper: is this IP/email currently on the blocklist? | |
| 591 | sub _phase3_is_blocked { | |
| 592 | my ($db, $dbh, $DB, $ip, $email) = @_; | |
| 593 | my $ip_q = defined $ip ? $ip : ''; | |
| 594 | my $email_q = defined $email ? lc($email) : ''; | |
| 595 | $ip_q =~ s/[^0-9a-fA-F:.]//g; | |
| 596 | $email_q =~ s/[\\']/\\$&/g; | |
| 597 | my $domain = ''; | |
| 598 | if ($email_q =~ /\@(.+)$/) { $domain = $1; } | |
| 599 | my $sql = qq{ | |
| 600 | SELECT COUNT(*) AS n FROM ${DB}.blocklist | |
| 601 | WHERE active=1 | |
| 602 | AND ( | |
| 603 | (kind='ip' AND value='$ip_q') OR | |
| 604 | (kind='email' AND value='$email_q') OR | |
| 605 | (kind='email_domain' AND value='$domain') | |
| 606 | ) | |
| 607 | LIMIT 1 | |
| 608 | }; | |
| 609 | my $r = $db->db_readwrite($dbh, $sql, $ENV{SCRIPT_NAME}, __LINE__); | |
| 610 | return ($r && $r->{n}) ? 1 : 0; | |
| 611 | } | |
| 612 | ||
| 613 | 1; |