added on local at 2026-07-01 15:02:53
| 1 | package MODS::ContactForge::EmailVerify; | |
| 2 | #====================================================================== | |
| 3 | # ContactForge - email verification helper. | |
| 4 | # | |
| 5 | # Two callers: | |
| 6 | # signup.cgi -> right after creating the user row, send verification | |
| 7 | # settings.cgi -> "Resend verification" button when not yet verified | |
| 8 | # | |
| 9 | # Behavior is deliberately NON-BLOCKING: the user can still use the | |
| 10 | # site while unverified. Verification stamps email_verified_at and (if | |
| 11 | # the row was still pending_verification) flips account_status='active'. | |
| 12 | # Most accounts come out of signup at status='active' already because | |
| 13 | # Login.pm::signup defaults to that -- verification is the deliverable | |
| 14 | # proof of address-control for transactional email (DMARC/DKIM), not | |
| 15 | # a sign-in gate. | |
| 16 | # | |
| 17 | # Public surface: | |
| 18 | # send_for_user($db, $dbh, $DB, $user_row) -> { ok, error } | |
| 19 | # verify_token($db, $dbh, $DB, $token) -> { ok, user_id, error } | |
| 20 | # | |
| 21 | # Tokens are 64-char HMAC-SHA256 hex strings, valid for 7 days. | |
| 22 | #====================================================================== | |
| 23 | ||
| 24 | use strict; | |
| 25 | use warnings; | |
| 26 | use Digest::SHA qw(hmac_sha256_hex); | |
| 27 | use MODS::ContactForge::Config; | |
| 28 | use MODS::ContactForge::Mailer; | |
| 29 | ||
| 30 | use constant VERIFY_WINDOW_DAYS => 7; | |
| 31 | ||
| 32 | sub _table_ready { | |
| 33 | my ($db, $dbh, $DB) = @_; | |
| 34 | my $r = $db->db_readwrite($dbh, qq~ | |
| 35 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 36 | WHERE table_schema='$DB' AND table_name='email_verifications' | |
| 37 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 38 | return ($r && $r->{n}) ? 1 : 0; | |
| 39 | } | |
| 40 | ||
| 41 | sub _secret { | |
| 42 | my $cfg = MODS::ContactForge::Config->new; | |
| 43 | return $cfg->settings('stripe_webhook_secret') | |
| 44 | || $cfg->settings('stripe_secret') | |
| 45 | || 'contactforge-static-fallback'; | |
| 46 | } | |
| 47 | ||
| 48 | sub _base_url { | |
| 49 | my $proto = 'http'; | |
| 50 | $proto = 'https' if ($ENV{HTTPS} || '') =~ /^on$/i; | |
| 51 | $proto = 'https' if ($ENV{HTTP_X_FORWARDED_PROTO} || '') =~ /^https$/i; | |
| 52 | my $host = $ENV{HTTP_HOST} || 'contactforge.com'; | |
| 53 | return "$proto://$host"; | |
| 54 | } | |
| 55 | ||
| 56 | sub _h { | |
| 57 | my $s = shift; $s = '' unless defined $s; | |
| 58 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 59 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 60 | return $s; | |
| 61 | } | |
| 62 | ||
| 63 | # Mint + email a verification link. $user_row needs id, email, and | |
| 64 | # display_name. Returns { ok => 1 } on send attempted, { ok => 0, | |
| 65 | # error => '...' } on misconfig. Mailer failures count as ok=0. | |
| 66 | sub send_for_user { | |
| 67 | my ($class, $db, $dbh, $DB, $user_row) = @_; | |
| 68 | return { ok => 0, error => 'no user' } unless $user_row && $user_row->{id}; | |
| 69 | return { ok => 0, error => 'schema missing' } unless _table_ready($db, $dbh, $DB); | |
| 70 | ||
| 71 | my $cfg = MODS::ContactForge::Config->new; | |
| 72 | my $mailer = MODS::ContactForge::Mailer->new; | |
| 73 | return { ok => 0, error => 'mailer not configured' } unless $mailer->is_configured; | |
| 74 | ||
| 75 | my $uid = $user_row->{id}; $uid =~ s/[^0-9]//g; | |
| 76 | return { ok => 0, error => 'bad uid' } unless $uid; | |
| 77 | ||
| 78 | my $rand = ''; | |
| 79 | $rand .= chr(int(rand(256))) for 1..32; | |
| 80 | my $token = hmac_sha256_hex($uid . '|' . time() . '|' . $rand, _secret()); | |
| 81 | ||
| 82 | my $ip = $ENV{REMOTE_ADDR} || ''; $ip =~ s/'/''/g; $ip = substr($ip, 0, 45); | |
| 83 | ||
| 84 | $db->db_readwrite($dbh, qq~ | |
| 85 | INSERT INTO `${DB}`.email_verifications | |
| 86 | SET user_id='$uid', | |
| 87 | token='$token', | |
| 88 | requested_ip='$ip', | |
| 89 | expires_at=DATE_ADD(NOW(), INTERVAL ~ . VERIFY_WINDOW_DAYS . qq~ DAY) | |
| 90 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 91 | ||
| 92 | my $base = _base_url(); | |
| 93 | my $link = "$base/verify_email.cgi?t=$token"; | |
| 94 | my $brand = $cfg->settings('brand_name') || 'ContactForge'; | |
| 95 | my $name = $user_row->{display_name} || 'there'; | |
| 96 | ||
| 97 | my $body = "Hi $name,\n\n" | |
| 98 | . "Thanks for creating a $brand account. Please confirm your email\n" | |
| 99 | . "address by visiting this link (valid for " . VERIFY_WINDOW_DAYS . " days):\n\n" | |
| 100 | . "$link\n\n" | |
| 101 | . "Verification keeps your account safe and helps make sure receipts and\n" | |
| 102 | . "billing emails reach you. You can use the site without verifying, but a\n" | |
| 103 | . "few features (sending replies to contact comments, custom-domain SSL\n" | |
| 104 | . "issuance) require a confirmed address.\n\n" | |
| 105 | . "If you did not create this account, you can ignore this email.\n\n" | |
| 106 | . "-- $brand\n"; | |
| 107 | ||
| 108 | my $html = '<p>Hi ' . _h($name) . ',</p>' | |
| 109 | . '<p>Thanks for creating a ' . _h($brand) . ' account. Please confirm your email address:</p>' | |
| 110 | . '<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">Verify my email</a></p>' | |
| 111 | . '<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>' | |
| 112 | . '<p style="font-size:13px;color:#475569">This link is valid for ' . VERIFY_WINDOW_DAYS . ' days. If you did not create this account you can ignore this email.</p>'; | |
| 113 | ||
| 114 | my $r = $mailer->send( | |
| 115 | to => $user_row->{email}, | |
| 116 | subject => "Confirm your $brand email", | |
| 117 | body => $body, | |
| 118 | html => $html, | |
| 119 | ); | |
| 120 | return $r; | |
| 121 | } | |
| 122 | ||
| 123 | # Verify a token presented to /verify_email.cgi. On success stamps | |
| 124 | # email_verified_at + promotes account_status if still pending. The | |
| 125 | # token row is marked used_at so it can't be replayed. | |
| 126 | sub verify_token { | |
| 127 | my ($class, $db, $dbh, $DB, $token) = @_; | |
| 128 | return { ok => 0, error => 'no token' } unless defined $token && length $token; | |
| 129 | return { ok => 0, error => 'schema missing' } unless _table_ready($db, $dbh, $DB); | |
| 130 | ||
| 131 | my $safe = $token; $safe =~ s/[^a-fA-F0-9]//g; $safe = substr($safe, 0, 64); | |
| 132 | return { ok => 0, error => 'bad token' } unless length($safe) == 64; | |
| 133 | ||
| 134 | my $row = $db->db_readwrite($dbh, qq~ | |
| 135 | SELECT id, user_id, used_at, (expires_at >= NOW()) AS still_valid | |
| 136 | FROM `${DB}`.email_verifications | |
| 137 | WHERE token='$safe' LIMIT 1 | |
| 138 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 139 | return { ok => 0, error => 'token not found' } unless $row && $row->{id}; | |
| 140 | return { ok => 0, error => 'token already used' } if $row->{used_at}; | |
| 141 | return { ok => 0, error => 'token expired' } unless $row->{still_valid}; | |
| 142 | ||
| 143 | my $uid = $row->{user_id}; $uid =~ s/[^0-9]//g; | |
| 144 | ||
| 145 | # Burn the token first so a replay attempt sees it consumed even | |
| 146 | # if the user row update fails for some reason. | |
| 147 | $db->db_readwrite($dbh, qq~ | |
| 148 | UPDATE `${DB}`.email_verifications | |
| 149 | SET used_at=NOW() | |
| 150 | WHERE id='$row->{id}' AND used_at IS NULL | |
| 151 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 152 | ||
| 153 | # Stamp the user row. If the account was sitting in | |
| 154 | # pending_verification it flips to active here -- otherwise leave | |
| 155 | # whatever status it had (e.g. suspended admins keep being | |
| 156 | # suspended even if they happened to verify their email later). | |
| 157 | $db->db_readwrite($dbh, qq~ | |
| 158 | UPDATE `${DB}`.users | |
| 159 | SET email_verified_at=NOW(), | |
| 160 | account_status=CASE WHEN account_status='pending_verification' THEN 'active' ELSE account_status END | |
| 161 | WHERE id='$uid' | |
| 162 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 163 | return { ok => 1, user_id => $uid }; | |
| 164 | } | |
| 165 | ||
| 166 | 1; |