added on local at 2026-06-22 16:19:48
| 1 | package MODS::Login; | |
| 2 | #====================================================================== | |
| 3 | # Meta-Admin -- session-cookie login. Built minimal because there's | |
| 4 | # exactly one operator (Shawn) and we don't need self-signup, role | |
| 5 | # matrices, or email verification here. | |
| 6 | # | |
| 7 | # Public API: | |
| 8 | # login_verify() -> $userinfo hashref or undef | |
| 9 | # sign_in($email, $pw) -> ($user_id, $session_id) or (0, error) | |
| 10 | # sign_out($sid) -> void | |
| 11 | # set_password($uid, $pw) | |
| 12 | #====================================================================== | |
| 13 | use strict; | |
| 14 | use warnings; | |
| 15 | use Digest::SHA qw(sha256_hex); | |
| 16 | ||
| 17 | use MODS::DBConnect; | |
| 18 | use MODS::MetaAdmin::Config; | |
| 19 | ||
| 20 | my $cfg = MODS::MetaAdmin::Config->new; | |
| 21 | ||
| 22 | sub new { return bless({}, shift); } | |
| 23 | ||
| 24 | sub _parse_cookie { | |
| 25 | my $name = shift; | |
| 26 | my $raw = $ENV{HTTP_COOKIE} || ''; | |
| 27 | foreach my $pair (split /;\s*/, $raw) { | |
| 28 | my ($k, $v) = split /=/, $pair, 2; | |
| 29 | next unless defined $k && defined $v; | |
| 30 | $k =~ s/^\s+|\s+$//g; | |
| 31 | return $v if $k eq $name; | |
| 32 | } | |
| 33 | return undef; | |
| 34 | } | |
| 35 | ||
| 36 | sub _bcrypt_check { | |
| 37 | my ($plain, $hash) = @_; | |
| 38 | # Plesk doesn't always ship Crypt::Eksblowfish, so we use a | |
| 39 | # SHA-256(salt . pw) scheme for this internal-only operator | |
| 40 | # account. Hash format: 'sha256$<hex_salt>$<hex_hash>'. The seed | |
| 41 | # row uses '$2a$10$REPLACEMEONFIRSTLOGIN' as a sentinel so the | |
| 42 | # first /login.cgi visit prompts a password set. | |
| 43 | return 0 if !$hash || !defined $plain; | |
| 44 | if ($hash =~ /^\$2a\$10\$REPLACEMEONFIRSTLOGIN$/) { | |
| 45 | return 0; # never matches; first-login flow handles set | |
| 46 | } | |
| 47 | if ($hash =~ /^sha256\$([a-f0-9]+)\$([a-f0-9]+)$/) { | |
| 48 | my ($salt, $want) = ($1, $2); | |
| 49 | my $got = sha256_hex($salt . $plain); | |
| 50 | return ($got eq $want) ? 1 : 0; | |
| 51 | } | |
| 52 | return 0; | |
| 53 | } | |
| 54 | ||
| 55 | sub _hash_password { | |
| 56 | my ($plain) = @_; | |
| 57 | my @c = ('0'..'9','a'..'f'); | |
| 58 | my $salt = join '', map { $c[int rand @c] } 1..32; | |
| 59 | return 'sha256$' . $salt . '$' . sha256_hex($salt . $plain); | |
| 60 | } | |
| 61 | ||
| 62 | sub _gen_sid { | |
| 63 | my @c = ('a'..'z','A'..'Z',0..9); | |
| 64 | return join '', map { $c[int rand @c] } 1..48; | |
| 65 | } | |
| 66 | ||
| 67 | sub login_verify { | |
| 68 | my $self = shift; | |
| 69 | my $cookie_name = $cfg->settings('cookie_name') || 'meta_session'; | |
| 70 | my $sid = _parse_cookie($cookie_name); | |
| 71 | return undef unless $sid && $sid =~ /^[A-Za-z0-9]{48}$/; | |
| 72 | ||
| 73 | my $db = MODS::DBConnect->new; | |
| 74 | my $dbh = $db->db_connect(); | |
| 75 | return undef unless $dbh; | |
| 76 | ||
| 77 | my $sid_q = $sid; $sid_q =~ s/'/''/g; | |
| 78 | my $r = $db->db_readwrite($dbh, qq~ | |
| 79 | SELECT s.user_id, s.id AS session_id, | |
| 80 | u.email, u.display_name, u.is_super_admin, | |
| 81 | u.last_active_at, u.session_minutes_override | |
| 82 | FROM sessions s | |
| 83 | JOIN users u ON u.id = s.user_id | |
| 84 | WHERE s.id='$sid_q' AND s.expires_at > NOW() | |
| 85 | LIMIT 1 | |
| 86 | ~, __FILE__, __LINE__); | |
| 87 | unless ($r && $r->{user_id}) { | |
| 88 | $db->db_disconnect($dbh); | |
| 89 | return undef; | |
| 90 | } | |
| 91 | ||
| 92 | # === Sliding-session idle check === | |
| 93 | my $_idle = $r->{session_minutes_override} ? int($r->{session_minutes_override}) : int($cfg->settings('session_minutes') || 720); | |
| 94 | if ($r->{last_active_at}) { | |
| 95 | my $_exp = $db->db_readwrite($dbh, qq~ | |
| 96 | SELECT (TIMESTAMPDIFF(MINUTE, '$r->{last_active_at}', NOW()) > $_idle) AS expired | |
| 97 | ~, __FILE__, __LINE__); | |
| 98 | if ($_exp && $_exp->{expired}) { | |
| 99 | $db->db_readwrite($dbh, qq~DELETE FROM sessions WHERE id='$sid_q'~, __FILE__, __LINE__); | |
| 100 | $db->db_disconnect($dbh); | |
| 101 | return undef; | |
| 102 | } | |
| 103 | } | |
| 104 | ||
| 105 | # === Maintenance lockdown: only super_admins pass when locked === | |
| 106 | if ($cfg->settings('maintenance_locked') && !$r->{is_super_admin}) { | |
| 107 | $db->db_readwrite($dbh, qq~DELETE FROM sessions WHERE id='$sid_q'~, __FILE__, __LINE__); | |
| 108 | $db->db_disconnect($dbh); | |
| 109 | return undef; | |
| 110 | } | |
| 111 | ||
| 112 | # === Bump last_active_at === | |
| 113 | my $uid_q = int($r->{user_id}); | |
| 114 | $db->db_readwrite($dbh, qq~UPDATE users SET last_active_at = NOW() WHERE id = $uid_q~, __FILE__, __LINE__); | |
| 115 | ||
| 116 | $db->db_disconnect($dbh); | |
| 117 | return { | |
| 118 | user_id => $r->{user_id}, | |
| 119 | email => $r->{email}, | |
| 120 | display_name => $r->{display_name}, | |
| 121 | is_super_admin => $r->{is_super_admin}, | |
| 122 | }; | |
| 123 | } | |
| 124 | ||
| 125 | # returns ($user_id, $session_id) on success; (0, $error_msg) on fail. | |
| 126 | sub sign_in { | |
| 127 | my ($self, $email, $pw) = @_; | |
| 128 | return (0, 'email and password required') unless $email && defined $pw; | |
| 129 | ||
| 130 | my $db = MODS::DBConnect->new; | |
| 131 | my $dbh = $db->db_connect(); | |
| 132 | return (0, 'db unavailable') unless $dbh; | |
| 133 | ||
| 134 | my $em_q = lc $email; $em_q =~ s/'/''/g; | |
| 135 | my $r = $db->db_readwrite($dbh, qq~ | |
| 136 | SELECT id, password_hash FROM users WHERE LOWER(email)='$em_q' LIMIT 1 | |
| 137 | ~, __FILE__, __LINE__); | |
| 138 | unless ($r && $r->{id}) { | |
| 139 | $db->db_disconnect($dbh); | |
| 140 | return (0, 'no such operator'); | |
| 141 | } | |
| 142 | unless (_bcrypt_check($pw, $r->{password_hash})) { | |
| 143 | $db->db_disconnect($dbh); | |
| 144 | # Sentinel hash means "first-login" -- caller routes to set-password. | |
| 145 | return (0, ($r->{password_hash} =~ /REPLACEMEONFIRSTLOGIN/) | |
| 146 | ? 'first_login_required' | |
| 147 | : 'wrong password'); | |
| 148 | } | |
| 149 | my $uid = $r->{id}; | |
| 150 | ||
| 151 | # Maintenance lockdown: only super_admins can sign in when locked. | |
| 152 | if ($cfg->settings('maintenance_locked')) { | |
| 153 | my $isadm = $db->db_readwrite($dbh, qq~SELECT is_super_admin FROM users WHERE id='$uid' LIMIT 1~, __FILE__, __LINE__); | |
| 154 | unless ($isadm && $isadm->{is_super_admin}) { | |
| 155 | $db->db_disconnect($dbh); | |
| 156 | return (0, 'maintenance_locked'); | |
| 157 | } | |
| 158 | } | |
| 159 | ||
| 160 | my $sid = _gen_sid(); | |
| 161 | # 10-year safety-net expiry; real expiry is sliding via users.last_active_at. | |
| 162 | my $minutes = 5256000; | |
| 163 | my $ip = $ENV{REMOTE_ADDR} || ''; $ip =~ s/'/''/g; | |
| 164 | my $ua = $ENV{HTTP_USER_AGENT} || ''; $ua =~ s/'/''/g; $ua = substr($ua,0,250); | |
| 165 | $db->db_readwrite($dbh, qq~ | |
| 166 | INSERT INTO sessions (id, user_id, expires_at, ip_addr, user_agent) | |
| 167 | VALUES ('$sid', '$uid', DATE_ADD(NOW(), INTERVAL $minutes MINUTE), '$ip', '$ua') | |
| 168 | ~, __FILE__, __LINE__); | |
| 169 | $db->db_readwrite($dbh, qq~ | |
| 170 | UPDATE users SET last_login_at=NOW(), last_active_at=NOW() WHERE id='$uid' | |
| 171 | ~, __FILE__, __LINE__); | |
| 172 | $db->db_disconnect($dbh); | |
| 173 | return ($uid, $sid); | |
| 174 | } | |
| 175 | ||
| 176 | sub sign_out { | |
| 177 | my ($self, $sid) = @_; | |
| 178 | return unless $sid; | |
| 179 | my $db = MODS::DBConnect->new; | |
| 180 | my $dbh = $db->db_connect(); | |
| 181 | return unless $dbh; | |
| 182 | my $sid_q = $sid; $sid_q =~ s/'/''/g; | |
| 183 | $db->db_readwrite($dbh, qq~DELETE FROM sessions WHERE id='$sid_q'~, __FILE__, __LINE__); | |
| 184 | $db->db_disconnect($dbh); | |
| 185 | } | |
| 186 | ||
| 187 | sub set_password { | |
| 188 | my ($self, $uid, $pw) = @_; | |
| 189 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 190 | return 0 unless $uid && defined $pw && length($pw) >= 8; | |
| 191 | my $db = MODS::DBConnect->new; | |
| 192 | my $dbh = $db->db_connect(); | |
| 193 | return 0 unless $dbh; | |
| 194 | my $h = _hash_password($pw); $h =~ s/'/''/g; | |
| 195 | $db->db_readwrite($dbh, qq~ | |
| 196 | UPDATE users SET password_hash='$h' WHERE id='$uid' | |
| 197 | ~, __FILE__, __LINE__); | |
| 198 | $db->db_disconnect($dbh); | |
| 199 | return 1; | |
| 200 | } | |
| 201 | ||
| 202 | # cookie header helper used by login.cgi. | |
| 203 | sub cookie_header { | |
| 204 | my ($self, $sid) = @_; | |
| 205 | my $name = $cfg->settings('cookie_name') || 'meta_session'; | |
| 206 | # Persistent cookie -- server is sole authority via users.last_active_at. | |
| 207 | # Cookie lives 10 years; sliding session controls real expiry. | |
| 208 | my $minutes = 5256000; | |
| 209 | my $domain = $cfg->settings('cookie_domain') || ''; | |
| 210 | my $secure = $cfg->settings('secure_cookies') ? '; Secure' : ''; | |
| 211 | my $dom = length($domain) ? "; Domain=$domain" : ''; | |
| 212 | return "Set-Cookie: $name=$sid; Path=/; Max-Age=" . ($minutes * 60) . "$dom$secure; HttpOnly; SameSite=Lax"; | |
| 213 | } | |
| 214 | ||
| 215 | sub clear_cookie_header { | |
| 216 | my $self = shift; | |
| 217 | my $name = $cfg->settings('cookie_name') || 'meta_session'; | |
| 218 | return "Set-Cookie: $name=; Path=/; Max-Age=0; HttpOnly"; | |
| 219 | } | |
| 220 | ||
| 221 | 1; |