added on WebSTLs (webstls.com) at 2026-07-01 22:26:31
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs -- Seller-side customer (buyer) directory + per-buyer detail. | |
| 4 | # | |
| 5 | # GET /customers.cgi | |
| 6 | # List every buyer who has placed an order or holds store credit | |
| 7 | # on any storefront owned by the signed-in seller. Columns: email, | |
| 8 | # display name, storefront, lifetime spend, order count, current | |
| 9 | # store-credit balance. | |
| 10 | # | |
| 11 | # GET /customers.cgi?sid=S&b=N | |
| 12 | # Detail view for one buyer on one storefront. Shows orders, credit | |
| 13 | # history, and (with refund_orders ptag) a Grant Credit button. | |
| 14 | # | |
| 15 | # GET /customers.cgi?sid=S&email=foo@bar.com | |
| 16 | # Detail view for a guest-checkout buyer (no buyer_accounts row). | |
| 17 | #====================================================================== | |
| 18 | use strict; | |
| 19 | use warnings; | |
| 20 | ||
| 21 | use lib '/var/www/vhosts/webstls.com/httpdocs'; | |
| 22 | use CGI; | |
| 23 | use MODS::Template; | |
| 24 | use MODS::DBConnect; | |
| 25 | use MODS::Login; | |
| 26 | use MODS::WebSTLs::Config; | |
| 27 | use MODS::WebSTLs::Wrapper; | |
| 28 | use MODS::WebSTLs::Permissions; | |
| 29 | use MODS::WebSTLs::BuyerCredits; | |
| 30 | ||
| 31 | my $q = CGI->new; | |
| 32 | my $form = $q->Vars; | |
| 33 | my $auth = MODS::Login->new; | |
| 34 | my $wrap = MODS::WebSTLs::Wrapper->new; | |
| 35 | my $tfile = MODS::Template->new; | |
| 36 | my $db = MODS::DBConnect->new; | |
| 37 | my $cfg = MODS::WebSTLs::Config->new; | |
| 38 | my $perm = MODS::WebSTLs::Permissions->new; | |
| 39 | my $bc = MODS::WebSTLs::BuyerCredits->new; | |
| 40 | my $DB = $cfg->settings('database_name'); | |
| 41 | ||
| 42 | $|=1; | |
| 43 | my $userinfo = $auth->login_verify(); | |
| 44 | unless ($userinfo) { | |
| 45 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 46 | exit; | |
| 47 | } | |
| 48 | ||
| 49 | my $entry = ($ENV{SCRIPT_NAME} || '') =~ m{/([^/]+)\.cgi$} ? $1 : 'customers'; | |
| 50 | ||
| 51 | if ($entry eq 'customer_action') { | |
| 52 | _handle_action($q, $form, $userinfo); | |
| 53 | exit; | |
| 54 | } | |
| 55 | ||
| 56 | $perm->require_feature($userinfo, 'view_orders'); | |
| 57 | ||
| 58 | my $uid = $userinfo->{user_id}; | |
| 59 | $uid =~ s/[^0-9]//g; | |
| 60 | my $owner_uid = $userinfo->{owner_user_id} || $uid; | |
| 61 | $owner_uid =~ s/[^0-9]//g; | |
| 62 | my $can_grant = $perm->has_feature($userinfo, 'refund_orders') ? 1 : 0; | |
| 63 | ||
| 64 | my $dbh = $db->db_connect(); | |
| 65 | ||
| 66 | # Flash from customer_action.cgi. | |
| 67 | my ($flash_msg, $flash_kind) = ('', ''); | |
| 68 | if (defined $form->{ok}) { | |
| 69 | my $k = $form->{ok}; $k =~ s/[^a-z_]//g; | |
| 70 | my %h = ( | |
| 71 | credit_granted => 'Credit granted.', | |
| 72 | credit_failed => 'Could not grant credit -- check the inputs.', | |
| 73 | ); | |
| 74 | $flash_msg = $h{$k} || 'Done.'; | |
| 75 | $flash_kind = 'ok'; | |
| 76 | } | |
| 77 | if (defined $form->{err}) { | |
| 78 | my $k = $form->{err}; $k =~ s/[^a-z_]//g; | |
| 79 | my %h = ( | |
| 80 | bad_input => 'Missing or invalid input.', | |
| 81 | denied => 'You do not have permission for that action.', | |
| 82 | not_found => 'Buyer or storefront not found.', | |
| 83 | schema => 'The buyer credit ledger table is not installed yet.', | |
| 84 | ); | |
| 85 | $flash_msg = $h{$k} || 'Error.'; | |
| 86 | $flash_kind = 'danger'; | |
| 87 | } | |
| 88 | ||
| 89 | my $sid_in = defined $form->{sid} ? $form->{sid} : ''; | |
| 90 | $sid_in =~ s/[^0-9]//g; | |
| 91 | my $b_in = defined $form->{b} ? $form->{b} : ''; | |
| 92 | $b_in =~ s/[^0-9]//g; | |
| 93 | my $email_in = defined $form->{email} ? $form->{email} : ''; | |
| 94 | $email_in =~ s/^\s+|\s+$//g; | |
| 95 | $email_in = substr($email_in, 0, 191); | |
| 96 | ||
| 97 | # Map of storefront_id -> 1 for the seller's owned stores. Used to | |
| 98 | # authorize ?sid= / ?b= queries (can't peek at someone else's customer). | |
| 99 | my %owned_sid; | |
| 100 | { | |
| 101 | my @sf = $db->db_readwrite_multiple($dbh, qq~ | |
| 102 | SELECT id FROM `${DB}`.storefronts WHERE user_id='$owner_uid' | |
| 103 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 104 | $owned_sid{$_->{id}} = 1 foreach @sf; | |
| 105 | } | |
| 106 | ||
| 107 | # Storefront pick used for "Grant credit to any email" button. Default | |
| 108 | # to the first owned storefront when no ?sid is in URL. | |
| 109 | my $default_sid = 0; | |
| 110 | foreach my $id (sort { $a <=> $b } keys %owned_sid) { $default_sid = $id; last; } | |
| 111 | ||
| 112 | # ====== Detail view ====================================================== | |
| 113 | if ($sid_in && $owned_sid{$sid_in} && ($b_in || length $email_in)) { | |
| 114 | _render_detail($sid_in, $b_in, $email_in); | |
| 115 | exit; | |
| 116 | } | |
| 117 | ||
| 118 | # ====== List view ======================================================== | |
| 119 | _render_list(); | |
| 120 | exit; | |
| 121 | ||
| 122 | # ---------------------------------------------------------------------- | |
| 123 | sub _render_list { | |
| 124 | # Aggregate orders to get one row per buyer per storefront. | |
| 125 | # We pull buyer_email as the canonical identity (every order has one) | |
| 126 | # and join buyer_accounts to surface the display name when registered. | |
| 127 | my @rows; | |
| 128 | if (keys %owned_sid) { | |
| 129 | my $sid_list = join(',', map { "'$_'" } keys %owned_sid); | |
| 130 | @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 131 | SELECT o.storefront_id, | |
| 132 | o.buyer_email, | |
| 133 | MAX(o.buyer_account_id) AS buyer_account_id, | |
| 134 | COUNT(*) AS order_count, | |
| 135 | SUM(CASE WHEN o.status='paid' THEN o.total_amount_cents ELSE 0 END) AS spent_cents, | |
| 136 | MAX(o.created_at) AS last_order_at, | |
| 137 | s.name AS store_name, | |
| 138 | ba.display_name AS display_name | |
| 139 | FROM `${DB}`.orders o | |
| 140 | JOIN `${DB}`.storefronts s ON s.id = o.storefront_id | |
| 141 | LEFT JOIN `${DB}`.buyer_accounts ba | |
| 142 | ON ba.id = o.buyer_account_id | |
| 143 | WHERE o.storefront_id IN ($sid_list) | |
| 144 | GROUP BY o.storefront_id, o.buyer_email, s.name, ba.display_name | |
| 145 | ORDER BY last_order_at DESC | |
| 146 | LIMIT 500 | |
| 147 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 148 | } | |
| 149 | ||
| 150 | my @list; | |
| 151 | foreach my $r (@rows) { | |
| 152 | my $bal = 0; | |
| 153 | if ($r->{buyer_account_id}) { | |
| 154 | $bal = $bc->balance_cents($db, $dbh, $DB, $r->{storefront_id}, | |
| 155 | { buyer_account_id => $r->{buyer_account_id} }); | |
| 156 | } else { | |
| 157 | $bal = $bc->balance_cents($db, $dbh, $DB, $r->{storefront_id}, | |
| 158 | { buyer_email => $r->{buyer_email} }); | |
| 159 | } | |
| 160 | ||
| 161 | my $detail_qs = $r->{buyer_account_id} | |
| 162 | ? "sid=$r->{storefront_id}&b=$r->{buyer_account_id}" | |
| 163 | : "sid=$r->{storefront_id}&email=" . _u($r->{buyer_email}); | |
| 164 | ||
| 165 | push @list, { | |
| 166 | store_name => _h($r->{store_name}), | |
| 167 | storefront_id => $r->{storefront_id} + 0, | |
| 168 | buyer_email => _h($r->{buyer_email}), | |
| 169 | display_name => _h($r->{display_name} || ''), | |
| 170 | has_account => $r->{buyer_account_id} ? 1 : 0, | |
| 171 | order_count => $r->{order_count} + 0, | |
| 172 | spent_dollars => '$' . sprintf('%.2f', ($r->{spent_cents} || 0)/100), | |
| 173 | last_order_at => $r->{last_order_at} || '-', | |
| 174 | balance_dollars => ($bal < 0 ? '-' : '') . '$' . sprintf('%.2f', abs($bal)/100), | |
| 175 | balance_cents => $bal + 0, | |
| 176 | has_credit => $bal > 0 ? 1 : 0, | |
| 177 | no_credit => $bal == 0 ? 1 : 0, | |
| 178 | has_debit => $bal < 0 ? 1 : 0, | |
| 179 | detail_qs => $detail_qs, | |
| 180 | }; | |
| 181 | } | |
| 182 | ||
| 183 | $db->db_disconnect($dbh); | |
| 184 | ||
| 185 | my $tvars = { | |
| 186 | rows => \@list, | |
| 187 | has_rows => scalar(@list) ? 1 : 0, | |
| 188 | no_rows => scalar(@list) ? 0 : 1, | |
| 189 | can_grant => $can_grant, | |
| 190 | default_sid => $default_sid + 0, | |
| 191 | flash_msg => $flash_msg, | |
| 192 | flash_kind => $flash_kind, | |
| 193 | has_flash => length $flash_msg ? 1 : 0, | |
| 194 | is_list_view => 1, | |
| 195 | is_detail_view => 0, | |
| 196 | }; | |
| 197 | ||
| 198 | 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"; | |
| 199 | my $body = join('', $tfile->template('webstls_customers.html', $tvars, $userinfo)); | |
| 200 | $wrap->render({ | |
| 201 | userinfo => $userinfo, | |
| 202 | page_key => 'customers', | |
| 203 | title => 'Customers', | |
| 204 | body => $body, | |
| 205 | }); | |
| 206 | } | |
| 207 | ||
| 208 | # ---------------------------------------------------------------------- | |
| 209 | sub _render_detail { | |
| 210 | my ($sid, $bid, $email) = @_; | |
| 211 | ||
| 212 | my $store = $db->db_readwrite($dbh, qq~ | |
| 213 | SELECT id, name FROM `${DB}`.storefronts WHERE id='$sid' LIMIT 1 | |
| 214 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 215 | unless ($store && $store->{id}) { | |
| 216 | $db->db_disconnect($dbh); | |
| 217 | print "Status: 302 Found\nLocation: /customers.cgi?err=not_found\n\n"; | |
| 218 | return; | |
| 219 | } | |
| 220 | ||
| 221 | # Resolve the buyer. Either we have a buyer_accounts.id, or we | |
| 222 | # only have an email (guest checkout case). | |
| 223 | my $buyer = { display_name => '', email => $email, has_account => 0, id => 0 }; | |
| 224 | if ($bid) { | |
| 225 | my $b = $db->db_readwrite($dbh, qq~ | |
| 226 | SELECT id, email, display_name, lifetime_value_cents, order_count, | |
| 227 | created_at, last_login_at | |
| 228 | FROM `${DB}`.buyer_accounts | |
| 229 | WHERE id='$bid' AND storefront_id='$sid' LIMIT 1 | |
| 230 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 231 | unless ($b && $b->{id}) { | |
| 232 | $db->db_disconnect($dbh); | |
| 233 | print "Status: 302 Found\nLocation: /customers.cgi?err=not_found\n\n"; | |
| 234 | return; | |
| 235 | } | |
| 236 | $buyer = { | |
| 237 | id => $b->{id} + 0, | |
| 238 | email => $b->{email}, | |
| 239 | display_name => $b->{display_name} || '', | |
| 240 | has_account => 1, | |
| 241 | lifetime_dollars => '$' . sprintf('%.2f', ($b->{lifetime_value_cents} || 0)/100), | |
| 242 | order_count => $b->{order_count} + 0, | |
| 243 | joined_at => $b->{created_at} || '-', | |
| 244 | last_login_at=> $b->{last_login_at} || 'Never', | |
| 245 | }; | |
| 246 | } else { | |
| 247 | # Guest path: also synthesize lifetime_value / order_count from orders. | |
| 248 | my $esc = $email; $esc =~ s/'/''/g; | |
| 249 | my $r = $db->db_readwrite($dbh, qq~ | |
| 250 | SELECT COUNT(*) AS n, | |
| 251 | SUM(CASE WHEN status='paid' THEN total_amount_cents ELSE 0 END) AS spent | |
| 252 | FROM `${DB}`.orders | |
| 253 | WHERE storefront_id='$sid' AND buyer_email='$esc' | |
| 254 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 255 | $buyer->{order_count} = $r ? ($r->{n} + 0) : 0; | |
| 256 | $buyer->{lifetime_dollars} = '$' . sprintf('%.2f', (($r ? $r->{spent} : 0) || 0)/100); | |
| 257 | $buyer->{joined_at} = '-'; | |
| 258 | $buyer->{last_login_at} = 'Never (guest checkout)'; | |
| 259 | } | |
| 260 | ||
| 261 | # Orders. Only SELECT store_credit_applied_cents when the schema | |
| 262 | # migration has run -- otherwise the column is absent and the | |
| 263 | # query would crash at the DBConnect layer. | |
| 264 | my @orders; | |
| 265 | { | |
| 266 | my $esc = $buyer->{email}; $esc =~ s/'/''/g; | |
| 267 | my $where = $buyer->{id} | |
| 268 | ? "buyer_account_id='$buyer->{id}'" | |
| 269 | : "buyer_account_id IS NULL AND buyer_email='$esc'"; | |
| 270 | my $credit_col = $bc->schema_ready($db, $dbh, $DB) | |
| 271 | ? 'store_credit_applied_cents' | |
| 272 | : '0 AS store_credit_applied_cents'; | |
| 273 | @orders = $db->db_readwrite_multiple($dbh, qq~ | |
| 274 | SELECT id, total_amount_cents, currency, status, created_at, | |
| 275 | $credit_col | |
| 276 | FROM `${DB}`.orders | |
| 277 | WHERE storefront_id='$sid' AND $where | |
| 278 | ORDER BY created_at DESC | |
| 279 | LIMIT 50 | |
| 280 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 281 | } | |
| 282 | my @order_rows; | |
| 283 | foreach my $o (@orders) { | |
| 284 | my $credit_used = $o->{store_credit_applied_cents} || 0; | |
| 285 | push @order_rows, { | |
| 286 | id => $o->{id} + 0, | |
| 287 | placed_at => $o->{created_at} || '-', | |
| 288 | status => $o->{status}, | |
| 289 | status_label => ucfirst($o->{status} || 'pending'), | |
| 290 | is_paid => $o->{status} eq 'paid' ? 1 : 0, | |
| 291 | is_refunded => ($o->{status} eq 'refunded' || $o->{status} eq 'partially_refunded') ? 1 : 0, | |
| 292 | total_dollars => '$' . sprintf('%.2f', ($o->{total_amount_cents} || 0)/100), | |
| 293 | credit_used_dollars => $credit_used > 0 ? ('$' . sprintf('%.2f', $credit_used/100)) : '', | |
| 294 | has_credit_used => $credit_used > 0 ? 1 : 0, | |
| 295 | }; | |
| 296 | } | |
| 297 | ||
| 298 | # Credit history. | |
| 299 | my @hist = $bc->history($db, $dbh, $DB, $sid, | |
| 300 | ($buyer->{id} ? { buyer_account_id => $buyer->{id} } : { buyer_email => $buyer->{email} }), 100); | |
| 301 | my @hist_rows; | |
| 302 | foreach my $h (@hist) { | |
| 303 | my $a = $h->{amount_cents} || 0; | |
| 304 | my %label = ( | |
| 305 | manual_grant => 'Goodwill grant', | |
| 306 | order_refund => 'Refund as credit', | |
| 307 | promotional => 'Promotional', | |
| 308 | order_apply => 'Used on order', | |
| 309 | reversal => 'Reversed (order refunded)', | |
| 310 | ); | |
| 311 | push @hist_rows, { | |
| 312 | id => $h->{id} + 0, | |
| 313 | amount_dollars => ($a < 0 ? '-' : '+') . '$' . sprintf('%.2f', abs($a)/100), | |
| 314 | is_positive => $a > 0 ? 1 : 0, | |
| 315 | is_negative => $a < 0 ? 1 : 0, | |
| 316 | reason => $h->{reason}, | |
| 317 | reason_label => $label{$h->{reason}} || $h->{reason}, | |
| 318 | related_order_id => $h->{related_order_id} ? ($h->{related_order_id} + 0) : 0, | |
| 319 | has_related => $h->{related_order_id} ? 1 : 0, | |
| 320 | note => _h($h->{note} || ''), | |
| 321 | created_at => $h->{created_at} || '-', | |
| 322 | }; | |
| 323 | } | |
| 324 | ||
| 325 | my $balance = $bc->balance_cents($db, $dbh, $DB, $sid, | |
| 326 | ($buyer->{id} ? { buyer_account_id => $buyer->{id} } : { buyer_email => $buyer->{email} })); | |
| 327 | ||
| 328 | $db->db_disconnect($dbh); | |
| 329 | ||
| 330 | my $tvars = { | |
| 331 | is_list_view => 0, | |
| 332 | is_detail_view => 1, | |
| 333 | can_grant => $can_grant, | |
| 334 | flash_msg => $flash_msg, | |
| 335 | flash_kind => $flash_kind, | |
| 336 | has_flash => length $flash_msg ? 1 : 0, | |
| 337 | ||
| 338 | store_id => $store->{id} + 0, | |
| 339 | store_name => _h($store->{name}), | |
| 340 | ||
| 341 | buyer_id => $buyer->{id} + 0, | |
| 342 | buyer_email => _h($buyer->{email}), | |
| 343 | buyer_name => _h($buyer->{display_name} || $buyer->{email}), | |
| 344 | buyer_has_account => $buyer->{has_account} ? 1 : 0, | |
| 345 | buyer_no_account => $buyer->{has_account} ? 0 : 1, | |
| 346 | buyer_lifetime => $buyer->{lifetime_dollars}, | |
| 347 | buyer_order_count => $buyer->{order_count}, | |
| 348 | buyer_joined => $buyer->{joined_at}, | |
| 349 | buyer_last_login => $buyer->{last_login_at}, | |
| 350 | ||
| 351 | balance_cents => $balance + 0, | |
| 352 | balance_dollars => ($balance < 0 ? '-' : '') . '$' . sprintf('%.2f', abs($balance)/100), | |
| 353 | has_credit => $balance > 0 ? 1 : 0, | |
| 354 | no_credit => $balance == 0 ? 1 : 0, | |
| 355 | has_debit => $balance < 0 ? 1 : 0, | |
| 356 | ||
| 357 | orders => \@order_rows, | |
| 358 | has_orders => scalar(@order_rows) ? 1 : 0, | |
| 359 | no_orders => scalar(@order_rows) ? 0 : 1, | |
| 360 | ||
| 361 | history => \@hist_rows, | |
| 362 | has_history => scalar(@hist_rows) ? 1 : 0, | |
| 363 | no_history => scalar(@hist_rows) ? 0 : 1, | |
| 364 | }; | |
| 365 | ||
| 366 | 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"; | |
| 367 | my $body = join('', $tfile->template('webstls_customers.html', $tvars, $userinfo)); | |
| 368 | $wrap->render({ | |
| 369 | userinfo => $userinfo, | |
| 370 | page_key => 'customers', | |
| 371 | title => 'Customer: ' . ($buyer->{display_name} || $buyer->{email}), | |
| 372 | body => $body, | |
| 373 | }); | |
| 374 | } | |
| 375 | ||
| 376 | sub _h { | |
| 377 | my $s = shift; $s = '' unless defined $s; | |
| 378 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 379 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 380 | return $s; | |
| 381 | } | |
| 382 | sub _u { | |
| 383 | my $s = shift; $s = '' unless defined $s; | |
| 384 | $s =~ s/([^A-Za-z0-9\-_.~])/sprintf('%%%02X', ord($1))/eg; | |
| 385 | return $s; | |
| 386 | } | |
| 387 | ||
| 388 | #====================================================================== | |
| 389 | # customer_action entry: POST handler (grant_credit). | |
| 390 | #====================================================================== | |
| 391 | sub _handle_action { | |
| 392 | my ($q, $form, $userinfo) = @_; | |
| 393 | ||
| 394 | my $return_to = defined $form->{return_to} ? $form->{return_to} : '/customers.cgi'; | |
| 395 | $return_to = '/customers.cgi' unless $return_to =~ m{^/[^/]} || $return_to eq '/'; | |
| 396 | ||
| 397 | my $_go = sub { | |
| 398 | my ($qs) = @_; | |
| 399 | my $sep = ($return_to =~ /\?/) ? '&' : '?'; | |
| 400 | print "Status: 302 Found\nLocation: $return_to$sep$qs\n\n"; | |
| 401 | }; | |
| 402 | ||
| 403 | unless (($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 404 | $_go->('err=bad_input'); | |
| 405 | return; | |
| 406 | } | |
| 407 | ||
| 408 | my $act = defined $form->{act} ? $form->{act} : ''; | |
| 409 | unless ($act eq 'grant_credit') { | |
| 410 | $_go->('err=bad_input'); | |
| 411 | return; | |
| 412 | } | |
| 413 | ||
| 414 | my $caller_uid = $userinfo->{user_id}; | |
| 415 | $caller_uid =~ s/[^0-9]//g; | |
| 416 | my $owner_uid = $userinfo->{owner_user_id} || $caller_uid; | |
| 417 | $owner_uid =~ s/[^0-9]//g; | |
| 418 | ||
| 419 | unless ($perm->has_feature($userinfo, 'refund_orders')) { | |
| 420 | $_go->('err=denied'); | |
| 421 | return; | |
| 422 | } | |
| 423 | ||
| 424 | my $sid = defined $form->{storefront_id} ? $form->{storefront_id} : ''; | |
| 425 | $sid =~ s/[^0-9]//g; | |
| 426 | unless ($sid) { $_go->('err=bad_input'); return; } | |
| 427 | ||
| 428 | my $bid = defined $form->{buyer_account_id} ? $form->{buyer_account_id} : ''; | |
| 429 | $bid =~ s/[^0-9]//g; | |
| 430 | ||
| 431 | my $email = defined $form->{buyer_email} ? $form->{buyer_email} : ''; | |
| 432 | $email =~ s/^\s+|\s+$//g; | |
| 433 | $email = substr($email, 0, 191); | |
| 434 | ||
| 435 | unless ($bid || ($email =~ /\@/ && $email =~ /\./)) { | |
| 436 | $_go->('err=bad_input'); | |
| 437 | return; | |
| 438 | } | |
| 439 | ||
| 440 | my $amt = defined $form->{amount_cents} ? $form->{amount_cents} : ''; | |
| 441 | $amt =~ s/[^0-9]//g; | |
| 442 | unless ($amt && $amt > 0) { $_go->('err=bad_input'); return; } | |
| 443 | ||
| 444 | my $note = defined $form->{note} ? $form->{note} : ''; | |
| 445 | $note =~ s/[\r\n]+/ /g; | |
| 446 | $note = substr($note, 0, 480); | |
| 447 | ||
| 448 | my $dbh = $db->db_connect(); | |
| 449 | ||
| 450 | # Authorize storefront ownership. Platform admins always pass. | |
| 451 | my $is_admin = $userinfo->{is_admin} ? 1 : 0; | |
| 452 | unless ($is_admin) { | |
| 453 | my $owns = $db->db_readwrite($dbh, qq~ | |
| 454 | SELECT id FROM `${DB}`.storefronts | |
| 455 | WHERE id='$sid' AND user_id='$owner_uid' LIMIT 1 | |
| 456 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 457 | unless ($owns && $owns->{id}) { | |
| 458 | $db->db_disconnect($dbh); | |
| 459 | $_go->('err=denied'); | |
| 460 | return; | |
| 461 | } | |
| 462 | } | |
| 463 | ||
| 464 | unless ($bc->schema_ready($db, $dbh, $DB)) { | |
| 465 | $db->db_disconnect($dbh); | |
| 466 | $_go->('err=schema'); | |
| 467 | return; | |
| 468 | } | |
| 469 | ||
| 470 | # If buyer_account_id is given, verify it actually belongs to this | |
| 471 | # storefront -- otherwise a malicious admin could credit a buyer of | |
| 472 | # a different storefront via crafted POST. | |
| 473 | if ($bid) { | |
| 474 | my $ba = $db->db_readwrite($dbh, qq~ | |
| 475 | SELECT id, email FROM `${DB}`.buyer_accounts | |
| 476 | WHERE id='$bid' AND storefront_id='$sid' LIMIT 1 | |
| 477 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 478 | unless ($ba && $ba->{id}) { | |
| 479 | $db->db_disconnect($dbh); | |
| 480 | $_go->('err=not_found'); | |
| 481 | return; | |
| 482 | } | |
| 483 | # Use the canonical email from buyer_accounts so a follow-up guest | |
| 484 | # checkout (no session) under the same email finds the credit. | |
| 485 | $email = $ba->{email} unless length $email; | |
| 486 | } | |
| 487 | ||
| 488 | my $new_id = $bc->grant($db, $dbh, $DB, | |
| 489 | storefront_id => $sid, | |
| 490 | buyer_account_id => $bid || undef, | |
| 491 | buyer_email => $email, | |
| 492 | amount_cents => $amt, | |
| 493 | reason => 'manual_grant', | |
| 494 | granted_by_user_id => $caller_uid, | |
| 495 | note => $note, | |
| 496 | ); | |
| 497 | ||
| 498 | $db->db_disconnect($dbh); | |
| 499 | ||
| 500 | $_go->($new_id ? 'ok=credit_granted' : 'err=credit_failed'); | |
| 501 | } |