added on local at 2026-07-01 22:09:38
| 1 | package MODS::ShopCart::Mailer; | |
| 2 | #====================================================================== | |
| 3 | # TaskForge -- transactional email | |
| 4 | # | |
| 5 | # Tries Net::SMTP with platform_settings SMTP creds; falls back to | |
| 6 | # local sendmail; on total failure just logs to uploads/_mail.log so | |
| 7 | # the action still succeeds (we surface the URL in-app for invites). | |
| 8 | #====================================================================== | |
| 9 | ||
| 10 | use strict; | |
| 11 | use warnings; | |
| 12 | ||
| 13 | use MODS::ShopCart::Config; | |
| 14 | ||
| 15 | my $config = MODS::ShopCart::Config->new; | |
| 16 | ||
| 17 | # Vars that are allowed to contain URLs unchanged. Everything else passed | |
| 18 | # in vars{} gets URL-stripped + length-capped before substitution so an | |
| 19 | # attacker can't smuggle a payload through display_name / company_name | |
| 20 | # / inviter_name / etc. | |
| 21 | my %URL_ALLOWED = map { $_ => 1 } qw( | |
| 22 | unsubscribe_url billing_url dashboard_url action_url | |
| 23 | invite_url accept_url reset_url login_url logout_url | |
| 24 | verify_url support_url abuse_url | |
| 25 | ); | |
| 26 | ||
| 27 | # Slugs that bypass the account-age gate. Without these, a brand-new | |
| 28 | # signup couldn't verify their own email or reset their password. | |
| 29 | my %AGE_GATE_BYPASS = map { $_ => 1 } qw( | |
| 30 | password_reset email_verify verify_email welcome | |
| 31 | ); | |
| 32 | ||
| 33 | sub _setting { | |
| 34 | my ($key, $default) = @_; | |
| 35 | my $v = $config->settings($key); | |
| 36 | return (defined $v && $v ne '') ? $v : $default; | |
| 37 | } | |
| 38 | ||
| 39 | sub new { | |
| 40 | my ($class) = @_; | |
| 41 | return bless({}, $class); | |
| 42 | } | |
| 43 | ||
| 44 | # send(to => '...', subject => '...', body_text => '...', body_html => '...') | |
| 45 | sub send { | |
| 46 | my ($self, %a) = @_; | |
| 47 | my $to = $a{to} || return 0; | |
| 48 | my $subject = $a{subject} || '(no subject)'; | |
| 49 | my $body = $a{body_html} || $a{body_text} || ''; | |
| 50 | my $is_html = exists $a{body_html} ? 1 : 0; | |
| 51 | my $from = $config->settings('from_email') || 'noreply@shop.3dshawn.com'; | |
| 52 | my $brand = $config->settings('brand_name') || 'ShopCart'; | |
| 53 | my $from_h = qq~"$brand" <$from>~; | |
| 54 | ||
| 55 | # Try SMTP | |
| 56 | my $smtp_host = $config->settings('smtp_host') || ''; | |
| 57 | my $bounce = 0; | |
| 58 | if ($smtp_host) { | |
| 59 | if (_send_smtp($smtp_host, $config->settings('smtp_port') || 587, | |
| 60 | $config->settings('smtp_user') || '', | |
| 61 | $config->settings('smtp_pass') || '', | |
| 62 | $from_h, $to, $subject, $body, $is_html, \$bounce)) { | |
| 63 | _log("smtp ok", $to, $subject); | |
| 64 | return 1; | |
| 65 | } | |
| 66 | _log($bounce ? "smtp bounce" : "smtp fail", $to, $subject); | |
| 67 | $self->{_last_bounce} = $bounce; | |
| 68 | return 0 if $bounce; # don't fall back to sendmail for known bounces | |
| 69 | } | |
| 70 | ||
| 71 | # Try local sendmail | |
| 72 | if (_send_sendmail($from_h, $to, $subject, $body, $is_html)) { | |
| 73 | _log("sendmail ok", $to, $subject); | |
| 74 | return 1; | |
| 75 | } | |
| 76 | _log("all fail", $to, $subject); | |
| 77 | return 0; | |
| 78 | } | |
| 79 | ||
| 80 | sub _send_smtp { | |
| 81 | my ($host, $port, $user, $pass, $from_h, $to, $subject, $body, $is_html, $bounce_ref) = @_; | |
| 82 | $$bounce_ref = 0 if ref $bounce_ref; | |
| 83 | return 0 unless eval { require Net::SMTP; 1 }; | |
| 84 | my $smtp = eval { Net::SMTP->new($host, Port => $port, Timeout => 15, Hello => 'shop.3dshawn.com') }; | |
| 85 | return 0 unless $smtp; | |
| 86 | if ($user && $pass) { | |
| 87 | eval { $smtp->auth($user, $pass) } or do { $smtp->quit; return 0; }; | |
| 88 | } | |
| 89 | my ($from_addr) = ($from_h =~ /<(.+?)>/); $from_addr ||= $from_h; | |
| 90 | eval { $smtp->mail($from_addr) } or do { $smtp->quit; return 0; }; | |
| 91 | my $rcpt_ok = eval { $smtp->to($to) }; | |
| 92 | unless ($rcpt_ok) { | |
| 93 | my $code = eval { $smtp->code() } || 0; | |
| 94 | my $msg = eval { $smtp->message() } || ''; | |
| 95 | $$bounce_ref = 1 if ref($bounce_ref) && ($code >= 500 | |
| 96 | || $msg =~ /no such user|user unknown|recipient.*reject|invalid.*recipient|mailbox.*not.*found/i); | |
| 97 | $smtp->quit; return 0; | |
| 98 | } | |
| 99 | $smtp->data(); | |
| 100 | $smtp->datasend("From: $from_h\n"); | |
| 101 | $smtp->datasend("To: $to\n"); | |
| 102 | $smtp->datasend("Subject: $subject\n"); | |
| 103 | $smtp->datasend("MIME-Version: 1.0\n"); | |
| 104 | $smtp->datasend("Content-Type: " . ($is_html ? 'text/html' : 'text/plain') . "; charset=utf-8\n\n"); | |
| 105 | $smtp->datasend($body); | |
| 106 | $smtp->datasend("\n"); | |
| 107 | $smtp->dataend(); | |
| 108 | $smtp->quit; | |
| 109 | return 1; | |
| 110 | } | |
| 111 | ||
| 112 | sub _send_sendmail { | |
| 113 | my ($from_h, $to, $subject, $body, $is_html) = @_; | |
| 114 | my $sendmail = -x '/usr/sbin/sendmail' ? '/usr/sbin/sendmail' | |
| 115 | : -x '/usr/bin/sendmail' ? '/usr/bin/sendmail' : ''; | |
| 116 | return 0 unless $sendmail; | |
| 117 | open(my $fh, "|$sendmail -t -i") or return 0; | |
| 118 | my ($from_addr) = ($from_h =~ /<(.+?)>/); $from_addr ||= $from_h; | |
| 119 | print $fh "From: $from_h\n"; | |
| 120 | print $fh "To: $to\n"; | |
| 121 | print $fh "Subject: $subject\n"; | |
| 122 | print $fh "MIME-Version: 1.0\n"; | |
| 123 | print $fh "Content-Type: " . ($is_html ? 'text/html' : 'text/plain') . "; charset=utf-8\n\n"; | |
| 124 | print $fh $body; | |
| 125 | print $fh "\n"; | |
| 126 | close $fh; | |
| 127 | return $? == 0 ? 1 : 0; | |
| 128 | } | |
| 129 | ||
| 130 | sub _log { | |
| 131 | my ($status, $to, $subject) = @_; | |
| 132 | my $path = $config->settings('uploads_dir') || '/tmp'; | |
| 133 | $path .= '/_mail.log'; | |
| 134 | if (open(my $fh, '>>', $path)) { | |
| 135 | print $fh scalar(localtime), "\t", $status, "\t", $to, "\t", $subject, "\n"; | |
| 136 | close $fh; | |
| 137 | } | |
| 138 | } | |
| 139 | ||
| 140 | # --------------------------------------------------------------------- | |
| 141 | # send_template(slug => '...', user_id => N, vars => {...}) | |
| 142 | # | |
| 143 | # Look up an editable template by slug, fill {{vars}}, append the | |
| 144 | # unsubscribe footer (lifecycle/product/marketing only -- transactional | |
| 145 | # is forced through), respect user_email_preferences, log to | |
| 146 | # email_sends_log, and hand the rendered HTML to send(). | |
| 147 | # | |
| 148 | # Returns 1 on send, 0 on suppressed/failed. Always logs to email_sends_log. | |
| 149 | # --------------------------------------------------------------------- | |
| 150 | sub send_template { | |
| 151 | my ($self, %a) = @_; | |
| 152 | my $slug = $a{slug} or return 0; | |
| 153 | my $user_id = $a{user_id} + 0; | |
| 154 | my $vars = $a{vars} || {}; | |
| 155 | my $to_override = $a{to}; # optional override (e.g., admin "send test") | |
| 156 | ||
| 157 | require MODS::DBConnect; | |
| 158 | require MODS::ShopCart::Config; | |
| 159 | my $cfg = MODS::ShopCart::Config->new; | |
| 160 | my $DB = $cfg->settings('database_name'); | |
| 161 | my $db = MODS::DBConnect->new; | |
| 162 | my $dbh = eval { $db->db_connect() }; | |
| 163 | return 0 unless $dbh; | |
| 164 | ||
| 165 | # 1. Load template | |
| 166 | my $slug_q = $slug; $slug_q =~ s/'/''/g; | |
| 167 | my $tpl = $db->db_readwrite($dbh, qq~ | |
| 168 | SELECT id, slug, category, subject, body_html, is_active | |
| 169 | FROM `${DB}`.email_templates WHERE slug='$slug_q' LIMIT 1 | |
| 170 | ~, $0, __LINE__); | |
| 171 | unless ($tpl && $tpl->{id} && $tpl->{is_active}) { | |
| 172 | $self->_log_send($db, $dbh, $DB, $user_id, undef, $slug, '', '(no template)', 'failed', 'template missing or inactive'); | |
| 173 | eval { $db->db_disconnect($dbh) }; | |
| 174 | return 0; | |
| 175 | } | |
| 176 | ||
| 177 | # 2. Resolve recipient + load user info | |
| 178 | my $to_email = $to_override; | |
| 179 | my $user; | |
| 180 | if ($user_id) { | |
| 181 | $user = $db->db_readwrite($dbh, qq~ | |
| 182 | SELECT id, email, display_name, company_id FROM `${DB}`.users WHERE id='$user_id' LIMIT 1 | |
| 183 | ~, $0, __LINE__); | |
| 184 | $to_email ||= $user->{email} if $user; | |
| 185 | } | |
| 186 | unless ($to_email) { | |
| 187 | $self->_log_send($db, $dbh, $DB, $user_id, $tpl->{id}, $slug, '', $tpl->{subject}, 'failed', 'no recipient'); | |
| 188 | eval { $db->db_disconnect($dbh) }; | |
| 189 | return 0; | |
| 190 | } | |
| 191 | ||
| 192 | # 3. Check user prefs (transactional bypasses) | |
| 193 | if ($user_id && $tpl->{category} ne 'transactional') { | |
| 194 | my $pref = $db->db_readwrite($dbh, qq~ | |
| 195 | SELECT is_subscribed FROM `${DB}`.user_email_preferences | |
| 196 | WHERE user_id='$user_id' AND category='$tpl->{category}' LIMIT 1 | |
| 197 | ~, $0, __LINE__); | |
| 198 | # Default-on for lifecycle, default-off for product+marketing | |
| 199 | my $default_on = ($tpl->{category} eq 'lifecycle') ? 1 : 0; | |
| 200 | my $sub = (defined $pref->{is_subscribed}) ? ($pref->{is_subscribed} ? 1 : 0) : $default_on; | |
| 201 | unless ($sub) { | |
| 202 | $self->_log_send($db, $dbh, $DB, $user_id, $tpl->{id}, $slug, $to_email, $tpl->{subject}, 'suppressed_pref', "category=$tpl->{category}"); | |
| 203 | eval { $db->db_disconnect($dbh) }; | |
| 204 | return 0; | |
| 205 | } | |
| 206 | } | |
| 207 | ||
| 208 | # 4. Auto-fill standard vars + ensure unsubscribe URL exists | |
| 209 | $vars->{display_name} //= ($user && $user->{display_name}) || ''; | |
| 210 | $vars->{first_name} //= (split /\s+/, $vars->{display_name})[0] || ''; | |
| 211 | $vars->{billing_url} //= 'https://shop.3dshawn.com/billing.cgi'; | |
| 212 | $vars->{dashboard_url} //= 'https://shop.3dshawn.com/dashboard.cgi'; | |
| 213 | $vars->{unsubscribe_url} //= $self->_unsubscribe_url($db, $dbh, $DB, $user_id); | |
| 214 | $vars->{abuse_url} //= $self->_abuse_url($db, $dbh, $DB, $user_id, $slug); | |
| 215 | ||
| 216 | # 4b. Sanitize every var that's NOT a URL whitelist field. Closes the | |
| 217 | # "inviter_name = 'Free Bitcoin https://evil.tld'" payload-injection | |
| 218 | # vector — fixed template body can still carry a URL-bearing display | |
| 219 | # name into the recipient's inbox. | |
| 220 | foreach my $k (keys %$vars) { | |
| 221 | next if $URL_ALLOWED{$k}; | |
| 222 | $vars->{$k} = _sanitize_display_var($vars->{$k}); | |
| 223 | } | |
| 224 | ||
| 225 | # 4c. Rate limit BEFORE rendering and sending. Hits both the team-invite | |
| 226 | # flow and the admin "send test" flow at this single chokepoint. | |
| 227 | my ($ok_rl, $rl_reason) = $self->_rate_limit_check($db, $dbh, $DB, $user_id, $slug, $to_email); | |
| 228 | unless ($ok_rl) { | |
| 229 | $self->_log_send($db, $dbh, $DB, $user_id, $tpl->{id}, $slug, $to_email, $tpl->{subject}, | |
| 230 | 'suppressed_rate', $rl_reason); | |
| 231 | eval { $db->db_disconnect($dbh) }; | |
| 232 | return 0; | |
| 233 | } | |
| 234 | ||
| 235 | # 5. Render: {{var}} substitution | |
| 236 | my $subject = _render_vars($tpl->{subject}, $vars); | |
| 237 | my $body = _render_vars($tpl->{body_html}, $vars); | |
| 238 | ||
| 239 | # 6. Append footer (lifecycle/product/marketing -- not transactional) | |
| 240 | if ($tpl->{category} ne 'transactional') { | |
| 241 | $body .= qq~ | |
| 242 | <hr style="border:0;border-top:1px solid #e5e7eb;margin:32px 0 16px"> | |
| 243 | <p style="color:#94a3b8;font-size:11px;text-align:center;line-height:1.5"> | |
| 244 | You're receiving this because you have a ShopCart account.<br> | |
| 245 | <a href="$vars->{unsubscribe_url}" style="color:#94a3b8">Manage email preferences</a> · | |
| 246 | <a href="$vars->{unsubscribe_url}&unsub_all=1" style="color:#94a3b8">Unsubscribe all</a> · | |
| 247 | <a href="$vars->{abuse_url}" style="color:#94a3b8">Report this email as abuse</a> | |
| 248 | </p>~; | |
| 249 | } else { | |
| 250 | # Transactional gets a slimmer abuse-only footer (no unsubscribe -- legal) | |
| 251 | $body .= qq~ | |
| 252 | <hr style="border:0;border-top:1px solid #e5e7eb;margin:24px 0 12px"> | |
| 253 | <p style="color:#94a3b8;font-size:11px;text-align:center;line-height:1.5"> | |
| 254 | Didn't expect this email? <a href="$vars->{abuse_url}" style="color:#94a3b8">Report as abuse</a> | |
| 255 | </p>~; | |
| 256 | } | |
| 257 | ||
| 258 | eval { $db->db_disconnect($dbh) }; | |
| 259 | ||
| 260 | # 7. Send via the existing send() path | |
| 261 | $self->{_last_bounce} = 0; | |
| 262 | my $ok = $self->send( | |
| 263 | to => $to_email, | |
| 264 | subject => $subject, | |
| 265 | body_html => $body, | |
| 266 | ); | |
| 267 | my $bounced = $self->{_last_bounce} ? 1 : 0; | |
| 268 | ||
| 269 | # 8. Log + post-bounce suspension | |
| 270 | my $db2 = MODS::DBConnect->new; | |
| 271 | my $dbh2 = eval { $db2->db_connect() }; | |
| 272 | if ($dbh2) { | |
| 273 | my $status = $ok ? 'sent' : ($bounced ? 'bounced' : 'failed'); | |
| 274 | my $reason = $ok ? '' : ($bounced ? 'recipient rejected (5xx)' : 'mailer send returned false'); | |
| 275 | $self->_log_send($db2, $dbh2, $DB, $user_id, $tpl->{id}, $slug, $to_email, $subject, | |
| 276 | $status, $reason); | |
| 277 | if ($bounced) { | |
| 278 | $self->_check_bounce_suspension($db2, $dbh2, $DB, $user_id); | |
| 279 | } | |
| 280 | eval { $db2->db_disconnect($dbh2) }; | |
| 281 | } | |
| 282 | return $ok; | |
| 283 | } | |
| 284 | ||
| 285 | sub _render_vars { | |
| 286 | my ($s, $vars) = @_; | |
| 287 | return '' unless defined $s; | |
| 288 | foreach my $k (keys %$vars) { | |
| 289 | my $v = $vars->{$k}; $v = '' unless defined $v; | |
| 290 | $s =~ s/\{\{\s*\Q$k\E\s*\}\}/$v/g; | |
| 291 | } | |
| 292 | return $s; | |
| 293 | } | |
| 294 | ||
| 295 | sub _unsubscribe_url { | |
| 296 | my ($self, $db, $dbh, $DB, $user_id) = @_; | |
| 297 | return 'https://shop.3dshawn.com/unsubscribe.cgi' unless $user_id; | |
| 298 | ||
| 299 | # Reuse existing token if present; mint otherwise. | |
| 300 | my $r = $db->db_readwrite($dbh, qq~ | |
| 301 | SELECT token FROM `${DB}`.email_unsubscribe_tokens | |
| 302 | WHERE user_id='$user_id' ORDER BY id DESC LIMIT 1 | |
| 303 | ~, $0, __LINE__); | |
| 304 | my $tok = ($r && $r->{token}) ? $r->{token} : ''; | |
| 305 | unless ($tok) { | |
| 306 | my @c = ('a'..'z','A'..'Z',0..9); | |
| 307 | $tok = join('', map { $c[ int(rand(@c)) ] } 1..48); | |
| 308 | $db->db_readwrite($dbh, qq~ | |
| 309 | INSERT INTO `${DB}`.email_unsubscribe_tokens (user_id, token) VALUES ('$user_id', '$tok') | |
| 310 | ~, $0, __LINE__); | |
| 311 | } | |
| 312 | return "https://shop.3dshawn.com/unsubscribe.cgi?t=$tok"; | |
| 313 | } | |
| 314 | ||
| 315 | sub _abuse_url { | |
| 316 | my ($self, $db, $dbh, $DB, $user_id, $slug) = @_; | |
| 317 | # No user_id (e.g., admin-test): use a generic abuse landing | |
| 318 | return 'https://shop.3dshawn.com/report_abuse.cgi' unless $user_id; | |
| 319 | ||
| 320 | # Token doubles as the inviter pointer; one per (user_id, slug) is fine | |
| 321 | my $slug_q = $slug || ''; $slug_q =~ s/'/''/g; | |
| 322 | my $u_q = $user_id + 0; | |
| 323 | my $r = $db->db_readwrite($dbh, qq~ | |
| 324 | SELECT token FROM `${DB}`.email_unsubscribe_tokens | |
| 325 | WHERE user_id='$u_q' ORDER BY id DESC LIMIT 1 | |
| 326 | ~, $0, __LINE__); | |
| 327 | my $tok = ($r && $r->{token}) ? $r->{token} : ''; | |
| 328 | unless ($tok) { | |
| 329 | my @c = ('a'..'z','A'..'Z',0..9); | |
| 330 | $tok = join('', map { $c[ int(rand(@c)) ] } 1..48); | |
| 331 | $db->db_readwrite($dbh, qq~ | |
| 332 | INSERT INTO `${DB}`.email_unsubscribe_tokens (user_id, token) VALUES ('$u_q', '$tok') | |
| 333 | ~, $0, __LINE__); | |
| 334 | } | |
| 335 | return "https://shop.3dshawn.com/report_abuse.cgi?t=$tok&s=$slug_q"; | |
| 336 | } | |
| 337 | ||
| 338 | sub _sanitize_display_var { | |
| 339 | my ($v) = @_; | |
| 340 | return '' unless defined $v; | |
| 341 | $v =~ s/[\r\n\t]+/ /g; | |
| 342 | $v =~ s/[<>]//g; | |
| 343 | $v =~ s{https?://\S+}{[link removed]}gi; | |
| 344 | $v =~ s{(?<![\w.])www\.\S+}{[link removed]}gi; | |
| 345 | $v =~ s{(?<![\w.])\b[a-z0-9-]{2,}\.(?:com|net|org|io|co|me|biz|info|us|xyz|click|link|ru|cn|tk|ml|ga|cf|gq|top|win|loan|trade|app|dev)\b}{[link removed]}gi; | |
| 346 | $v =~ s/^\s+|\s+$//g; | |
| 347 | $v = substr($v, 0, 80) if length($v) > 80; | |
| 348 | return $v; | |
| 349 | } | |
| 350 | ||
| 351 | sub _rate_limit_check { | |
| 352 | my ($self, $db, $dbh, $DB, $user_id, $slug, $to_email) = @_; | |
| 353 | return (1, '') unless $user_id; | |
| 354 | my $u_q = $user_id + 0; | |
| 355 | ||
| 356 | my $hourly_cap = _setting('email_rate_hourly_cap', 20) + 0; | |
| 357 | my $daily_cap = _setting('email_rate_daily_cap', 100) + 0; | |
| 358 | my $dedupe_hours = _setting('email_dedupe_window_hours', 24) + 0; | |
| 359 | my $age_min_h = _setting('email_account_age_min_hours', 1) + 0; | |
| 360 | ||
| 361 | # 1. Active suspension (set by bounce / abuse triggers) | |
| 362 | my $u = $db->db_readwrite($dbh, qq~ | |
| 363 | SELECT email_suspended_until, email_suspended_reason, created_at | |
| 364 | FROM `${DB}`.users WHERE id='$u_q' LIMIT 1 | |
| 365 | ~, $0, __LINE__); | |
| 366 | if ($u && $u->{email_suspended_until}) { | |
| 367 | my $still = $db->db_readwrite($dbh, qq~ | |
| 368 | SELECT (email_suspended_until > NOW()) AS still | |
| 369 | FROM `${DB}`.users WHERE id='$u_q' LIMIT 1 | |
| 370 | ~, $0, __LINE__); | |
| 371 | if ($still && $still->{still}) { | |
| 372 | return (0, "inviter suspended until $u->{email_suspended_until} ($u->{email_suspended_reason})"); | |
| 373 | } | |
| 374 | } | |
| 375 | ||
| 376 | # 2. Account-age gate (skip for password reset / verify / welcome) | |
| 377 | if ($u && $u->{created_at} && !$AGE_GATE_BYPASS{$slug || ''}) { | |
| 378 | my $age = $db->db_readwrite($dbh, qq~ | |
| 379 | SELECT TIMESTAMPDIFF(HOUR, created_at, NOW()) AS h | |
| 380 | FROM `${DB}`.users WHERE id='$u_q' LIMIT 1 | |
| 381 | ~, $0, __LINE__); | |
| 382 | if ($age && defined $age->{h} && $age->{h} < $age_min_h) { | |
| 383 | return (0, "account too new ($age->{h}h < $age_min_h h)"); | |
| 384 | } | |
| 385 | } | |
| 386 | ||
| 387 | # 3. Hourly burst | |
| 388 | my $hr = $db->db_readwrite($dbh, qq~ | |
| 389 | SELECT COUNT(*) AS n FROM `${DB}`.email_sends_log | |
| 390 | WHERE user_id='$u_q' AND status='sent' | |
| 391 | AND sent_at > DATE_SUB(NOW(), INTERVAL 1 HOUR) | |
| 392 | ~, $0, __LINE__); | |
| 393 | return (0, "hourly burst cap ($hourly_cap)") if ($hr && ($hr->{n} || 0) >= $hourly_cap); | |
| 394 | ||
| 395 | # 4. Daily cap | |
| 396 | my $dy = $db->db_readwrite($dbh, qq~ | |
| 397 | SELECT COUNT(*) AS n FROM `${DB}`.email_sends_log | |
| 398 | WHERE user_id='$u_q' AND status='sent' | |
| 399 | AND sent_at > DATE_SUB(NOW(), INTERVAL 24 HOUR) | |
| 400 | ~, $0, __LINE__); | |
| 401 | return (0, "daily cap ($daily_cap)") if ($dy && ($dy->{n} || 0) >= $daily_cap); | |
| 402 | ||
| 403 | # 5. Duplicate to same recipient + same template | |
| 404 | my $to_q = $to_email; $to_q =~ s/'/''/g; | |
| 405 | my $slug_q = $slug; $slug_q =~ s/'/''/g; | |
| 406 | my $dp = $db->db_readwrite($dbh, qq~ | |
| 407 | SELECT COUNT(*) AS n FROM `${DB}`.email_sends_log | |
| 408 | WHERE user_id='$u_q' AND template_slug='$slug_q' AND to_email='$to_q' | |
| 409 | AND status='sent' AND sent_at > DATE_SUB(NOW(), INTERVAL $dedupe_hours HOUR) | |
| 410 | ~, $0, __LINE__); | |
| 411 | return (0, "duplicate send within ${dedupe_hours}h") if ($dp && ($dp->{n} || 0) >= 1); | |
| 412 | ||
| 413 | return (1, ''); | |
| 414 | } | |
| 415 | ||
| 416 | # Called from _send_smtp when the RCPT TO line returns 5xx. | |
| 417 | # Bumps inviter's bounce count; if rate exceeds threshold AND volume is | |
| 418 | # meaningful, set email_suspended_until = NOW() + N days. | |
| 419 | sub _check_bounce_suspension { | |
| 420 | my ($self, $db, $dbh, $DB, $user_id) = @_; | |
| 421 | return unless $user_id; | |
| 422 | my $u_q = $user_id + 0; | |
| 423 | ||
| 424 | my $pct_thresh = _setting('email_bounce_suspend_pct', 10) + 0; | |
| 425 | my $min_vol = _setting('email_bounce_min_volume', 20) + 0; | |
| 426 | my $susp_days = _setting('email_suspend_days', 7) + 0; | |
| 427 | ||
| 428 | my $r = $db->db_readwrite($dbh, qq~ | |
| 429 | SELECT | |
| 430 | SUM(CASE WHEN status='bounced' THEN 1 ELSE 0 END) AS bounces, | |
| 431 | SUM(CASE WHEN status IN ('sent','bounced') THEN 1 ELSE 0 END) AS total | |
| 432 | FROM `${DB}`.email_sends_log | |
| 433 | WHERE user_id='$u_q' | |
| 434 | AND created_at > DATE_SUB(NOW(), INTERVAL 7 DAY) | |
| 435 | ~, $0, __LINE__); | |
| 436 | return unless $r; | |
| 437 | my $b = ($r->{bounces} || 0) + 0; | |
| 438 | my $t = ($r->{total} || 0) + 0; | |
| 439 | return if $t < $min_vol; | |
| 440 | my $pct = ($b * 100) / $t; | |
| 441 | return if $pct < $pct_thresh; | |
| 442 | ||
| 443 | my $reason = sprintf("bounce rate %.1f%% (%d/%d) >= %d%%", $pct, $b, $t, $pct_thresh); | |
| 444 | $reason =~ s/'/''/g; | |
| 445 | $db->db_readwrite($dbh, qq~ | |
| 446 | UPDATE `${DB}`.users | |
| 447 | SET email_suspended_until = DATE_ADD(NOW(), INTERVAL $susp_days DAY), | |
| 448 | email_suspended_reason = '$reason' | |
| 449 | WHERE id='$u_q' | |
| 450 | ~, $0, __LINE__); | |
| 451 | } | |
| 452 | ||
| 453 | # Called from report_abuse.cgi after an abuse report is logged. | |
| 454 | sub abuse_suspend_check { | |
| 455 | my ($self, $db, $dbh, $DB, $inviter_user_id) = @_; | |
| 456 | return unless $inviter_user_id; | |
| 457 | my $u_q = $inviter_user_id + 0; | |
| 458 | ||
| 459 | my $thresh = _setting('email_abuse_suspend_threshold', 1) + 0; | |
| 460 | my $susp_days = _setting('email_suspend_days', 7) + 0; | |
| 461 | ||
| 462 | my $r = $db->db_readwrite($dbh, qq~ | |
| 463 | SELECT COUNT(*) AS n FROM `${DB}`.email_abuse_reports | |
| 464 | WHERE inviter_user_id='$u_q' | |
| 465 | AND reported_at > DATE_SUB(NOW(), INTERVAL 30 DAY) | |
| 466 | ~, $0, __LINE__); | |
| 467 | return unless $r && ($r->{n} || 0) >= $thresh; | |
| 468 | ||
| 469 | my $reason = sprintf("abuse reports: %d in 30d (threshold %d)", $r->{n}, $thresh); | |
| 470 | $reason =~ s/'/''/g; | |
| 471 | $db->db_readwrite($dbh, qq~ | |
| 472 | UPDATE `${DB}`.users | |
| 473 | SET email_suspended_until = DATE_ADD(NOW(), INTERVAL $susp_days DAY), | |
| 474 | email_suspended_reason = '$reason' | |
| 475 | WHERE id='$u_q' | |
| 476 | ~, $0, __LINE__); | |
| 477 | } | |
| 478 | ||
| 479 | sub _log_send { | |
| 480 | my ($self, $db, $dbh, $DB, $user_id, $template_id, $slug, $to, $subject, $status, $reason) = @_; | |
| 481 | my $uid_sql = $user_id ? "'$user_id'" : 'NULL'; | |
| 482 | my $tid_sql = $template_id ? "'$template_id'" : 'NULL'; | |
| 483 | my $slug_q = $slug; $slug_q =~ s/'/''/g; | |
| 484 | my $to_q = $to; $to_q =~ s/'/''/g; | |
| 485 | my $subj_q = substr($subject, 0, 250); $subj_q =~ s/'/''/g; | |
| 486 | my $st = $status; $st =~ s/[^a-z_]//g; | |
| 487 | my $rsn_q = substr($reason || '', 0, 500); $rsn_q =~ s/'/''/g; | |
| 488 | my $sent_at_sql = ($status eq 'sent') ? 'NOW()' : 'NULL'; | |
| 489 | ||
| 490 | eval { | |
| 491 | $db->db_readwrite($dbh, qq~ | |
| 492 | INSERT INTO `${DB}`.email_sends_log | |
| 493 | (user_id, template_id, template_slug, to_email, subject, status, failure_reason, sent_at) | |
| 494 | VALUES | |
| 495 | ($uid_sql, $tid_sql, '$slug_q', '$to_q', '$subj_q', '$st', '$rsn_q', $sent_at_sql) | |
| 496 | ~, $0, __LINE__); | |
| 497 | }; | |
| 498 | } | |
| 499 | ||
| 500 | 1; |