added on WebSTLs (webstls.com) at 2026-07-01 22:26:33
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs - Forgot password | |
| 4 | # | |
| 5 | # GET : show the email-entry form | |
| 6 | # POST : if the email matches a user row, mint a one-shot reset token, | |
| 7 | # email a link to /reset_password.cgi?t=..., and show a success | |
| 8 | # page. If the email DOESN'T match, show the same success page | |
| 9 | # anyway -- never leak which addresses are registered. | |
| 10 | # | |
| 11 | # Tokens expire after 60 minutes and are single-use. Concurrent active | |
| 12 | # tokens are allowed; we don't pre-revoke a user's prior unused tokens | |
| 13 | # in case a legitimate reset request crosses paths with a phishing | |
| 14 | # attempt that prompted them to request another one. | |
| 15 | #====================================================================== | |
| 16 | use strict; | |
| 17 | use warnings; | |
| 18 | ||
| 19 | use lib '/var/www/vhosts/webstls.com/httpdocs'; | |
| 20 | use CGI; | |
| 21 | use Digest::SHA qw(hmac_sha256_hex); | |
| 22 | use MODS::Template; | |
| 23 | use MODS::DBConnect; | |
| 24 | use MODS::Login; | |
| 25 | use MODS::WebSTLs::Config; | |
| 26 | use MODS::WebSTLs::Wrapper; | |
| 27 | use MODS::WebSTLs::Mailer; | |
| 28 | ||
| 29 | my $q = CGI->new; | |
| 30 | my $form = $q->Vars; | |
| 31 | my $auth = MODS::Login->new; | |
| 32 | my $wrap = MODS::WebSTLs::Wrapper->new; | |
| 33 | my $tfile = MODS::Template->new; | |
| 34 | my $db = MODS::DBConnect->new; | |
| 35 | my $cfg = MODS::WebSTLs::Config->new; | |
| 36 | my $DB = $cfg->settings('database_name'); | |
| 37 | ||
| 38 | $|=1; | |
| 39 | ||
| 40 | # Already signed in? bounce to dashboard -- forgot-password is for | |
| 41 | # signed-out users. | |
| 42 | if (my $existing = $auth->login_verify()) { | |
| 43 | print "Status: 302 Found\nLocation: /dashboard.cgi\n\n"; | |
| 44 | exit; | |
| 45 | } | |
| 46 | ||
| 47 | my $submitted = 0; | |
| 48 | my $error_msg = ''; | |
| 49 | ||
| 50 | if (($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 51 | my $email = lc(defined $form->{email} ? $form->{email} : ''); | |
| 52 | $email =~ s/^\s+|\s+$//g; | |
| 53 | $submitted = 1; | |
| 54 | ||
| 55 | if ($email !~ /^[^\s@]+\@[^\s@]+\.[^\s@]+$/) { | |
| 56 | $error_msg = 'Please enter a valid email address.'; | |
| 57 | $submitted = 0; | |
| 58 | } else { | |
| 59 | my $dbh = $db->db_connect(); | |
| 60 | ||
| 61 | # Confirm the password_resets table exists -- pre-migration | |
| 62 | # installs would 500 the SELECT otherwise. | |
| 63 | my $tab = $db->db_readwrite($dbh, qq~ | |
| 64 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 65 | WHERE table_schema='$DB' AND table_name='password_resets' | |
| 66 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 67 | ||
| 68 | if ($tab && $tab->{n}) { | |
| 69 | my $email_safe = $email; $email_safe =~ s/'/''/g; | |
| 70 | my $u = $db->db_readwrite($dbh, qq~ | |
| 71 | SELECT id, email, display_name FROM `${DB}`.users | |
| 72 | WHERE email='$email_safe' AND account_status='active' | |
| 73 | LIMIT 1 | |
| 74 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 75 | ||
| 76 | if ($u && $u->{id}) { | |
| 77 | my $token = _mint_token($u->{id}); | |
| 78 | my $uid = $u->{id}; | |
| 79 | my $ip = $ENV{REMOTE_ADDR} || ''; | |
| 80 | my $ua = $ENV{HTTP_USER_AGENT} || ''; | |
| 81 | $ip =~ s/'/''/g; $ua =~ s/'/''/g; | |
| 82 | $ip = substr($ip, 0, 45); | |
| 83 | $ua = substr($ua, 0, 255); | |
| 84 | ||
| 85 | $db->db_readwrite($dbh, qq~ | |
| 86 | INSERT INTO `${DB}`.password_resets | |
| 87 | SET user_id='$uid', | |
| 88 | token='$token', | |
| 89 | requested_ip='$ip', | |
| 90 | requested_user_agent='$ua', | |
| 91 | expires_at=DATE_ADD(NOW(), INTERVAL 60 MINUTE) | |
| 92 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 93 | ||
| 94 | my $base = _base_url(); | |
| 95 | my $link = "$base/reset_password.cgi?t=$token"; | |
| 96 | my $brand = $cfg->settings('brand_name') || 'WebSTLs'; | |
| 97 | my $name = $u->{display_name} || 'there'; | |
| 98 | ||
| 99 | my $body = "Hi $name,\n\n" | |
| 100 | . "Someone (hopefully you) asked to reset the password on your $brand account.\n\n" | |
| 101 | . "Use this link within the next 60 minutes:\n\n" | |
| 102 | . "$link\n\n" | |
| 103 | . "If you did not request this, you can ignore the email and your password stays unchanged.\n\n" | |
| 104 | . "Request details:\n" | |
| 105 | . " IP: $ip\n" | |
| 106 | . " Browser: $ua\n\n" | |
| 107 | . "-- $brand\n"; | |
| 108 | ||
| 109 | my $html = '<p>Hi ' . _h($name) . ',</p>' | |
| 110 | . '<p>Someone (hopefully you) asked to reset the password on your ' . _h($brand) . ' account.</p>' | |
| 111 | . '<p><a href="' . _h($link) . '" style="display:inline-block;background:#4f46e5;color:#fff;padding:10px 18px;border-radius:6px;text-decoration:none;font-weight:600">Reset my password</a></p>' | |
| 112 | . '<p style="font-size:13px;color:#475569">Or copy and paste this URL into your browser:<br><span style="word-break:break-all">' . _h($link) . '</span></p>' | |
| 113 | . '<p style="font-size:13px;color:#475569">This link expires in 60 minutes. If you did not request this, you can ignore the email and your password stays unchanged.</p>' | |
| 114 | . '<p style="font-size:12px;color:#94a3b8">Request from IP ' . _h($ip) . '</p>'; | |
| 115 | ||
| 116 | my $mailer = MODS::WebSTLs::Mailer->new; | |
| 117 | $mailer->send( | |
| 118 | to => $u->{email}, | |
| 119 | subject => "Reset your $brand password", | |
| 120 | body => $body, | |
| 121 | html => $html, | |
| 122 | ); | |
| 123 | # We intentionally do not surface mailer errors to the | |
| 124 | # browser -- doing so would let an attacker enumerate | |
| 125 | # which addresses exist. Errors land in apache logs | |
| 126 | # via STDERR for ops to spot. | |
| 127 | } | |
| 128 | } | |
| 129 | $db->db_disconnect($dbh); | |
| 130 | } | |
| 131 | } | |
| 132 | ||
| 133 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-store, no-cache, must-revalidate, max-age=0\nPragma: no-cache\nExpires: 0\n\n"; | |
| 134 | ||
| 135 | my $tvars = { | |
| 136 | submitted => $submitted, | |
| 137 | error_msg => $error_msg, | |
| 138 | has_error => length $error_msg ? 1 : 0, | |
| 139 | }; | |
| 140 | ||
| 141 | my $body = join('', $tfile->template('webstls_forgot_password.html', $tvars, undef)); | |
| 142 | ||
| 143 | $wrap->render({ | |
| 144 | userinfo => undef, | |
| 145 | title => 'Forgot password', | |
| 146 | body => $body, | |
| 147 | }); | |
| 148 | ||
| 149 | #---------------------------------------------------------------------- | |
| 150 | # Mint a 64-char hex token deterministic for (user_id, time, random | |
| 151 | # entropy). HMAC keyed off a per-process secret means even with read | |
| 152 | # access to one row's plaintext token, an attacker can't predict the | |
| 153 | # next one. | |
| 154 | sub _mint_token { | |
| 155 | my ($uid) = @_; | |
| 156 | my $key = $cfg->settings('stripe_webhook_secret') | |
| 157 | || $cfg->settings('stripe_secret') | |
| 158 | || 'webstls-static-fallback'; | |
| 159 | my $rand = ''; | |
| 160 | $rand .= chr(int(rand(256))) for 1..32; | |
| 161 | return hmac_sha256_hex($uid . '|' . time() . '|' . $rand, $key); | |
| 162 | } | |
| 163 | ||
| 164 | # Best-effort base URL from CGI env. Honors HTTPS detection on Plesk | |
| 165 | # (HTTPS=on or X-Forwarded-Proto=https through the reverse proxy). | |
| 166 | sub _base_url { | |
| 167 | my $proto = 'http'; | |
| 168 | $proto = 'https' if ($ENV{HTTPS} || '') =~ /^on$/i; | |
| 169 | $proto = 'https' if ($ENV{HTTP_X_FORWARDED_PROTO} || '') =~ /^https$/i; | |
| 170 | my $host = $ENV{HTTP_HOST} || 'webstls.com'; | |
| 171 | return "$proto://$host"; | |
| 172 | } | |
| 173 | ||
| 174 | sub _h { | |
| 175 | my $s = shift; $s = '' unless defined $s; | |
| 176 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 177 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 178 | return $s; | |
| 179 | } |