added on local at 2026-07-01 21:47:32
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # RePricer -- 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/3dshawn.com/repricer.3dshawn.com'; | |
| 22 | use CGI; | |
| 23 | use MODS::Template; | |
| 24 | use MODS::DBConnect; | |
| 25 | use MODS::Login; | |
| 26 | use MODS::RePricer::Config; | |
| 27 | use MODS::RePricer::Wrapper; | |
| 28 | use MODS::RePricer::Permissions; | |
| 29 | use MODS::RePricer::BuyerCredits; | |
| 30 | ||
| 31 | my $q = CGI->new; | |
| 32 | my $form = $q->Vars; | |
| 33 | my $auth = MODS::Login->new; | |
| 34 | my $wrap = MODS::RePricer::Wrapper->new; | |
| 35 | my $tfile = MODS::Template->new; | |
| 36 | my $db = MODS::DBConnect->new; | |
| 37 | my $cfg = MODS::RePricer::Config->new; | |
| 38 | my $perm = MODS::RePricer::Permissions->new; | |
| 39 | my $bc = MODS::RePricer::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 | $perm->require_feature($userinfo, 'view_orders'); | |
| 49 | ||
| 50 | my $uid = $userinfo->{user_id}; | |
| 51 | $uid =~ s/[^0-9]//g; | |
| 52 | my $owner_uid = $userinfo->{owner_user_id} || $uid; | |
| 53 | $owner_uid =~ s/[^0-9]//g; | |
| 54 | my $can_grant = $perm->has_feature($userinfo, 'refund_orders') ? 1 : 0; | |
| 55 | ||
| 56 | my $dbh = $db->db_connect(); | |
| 57 | ||
| 58 | # Flash from customer_action.cgi. | |
| 59 | my ($flash_msg, $flash_kind) = ('', ''); | |
| 60 | if (defined $form->{ok}) { | |
| 61 | my $k = $form->{ok}; $k =~ s/[^a-z_]//g; | |
| 62 | my %h = ( | |
| 63 | credit_granted => 'Credit granted.', | |
| 64 | credit_failed => 'Could not grant credit -- check the inputs.', | |
| 65 | ); | |
| 66 | $flash_msg = $h{$k} || 'Done.'; | |
| 67 | $flash_kind = 'ok'; | |
| 68 | } | |
| 69 | if (defined $form->{err}) { | |
| 70 | my $k = $form->{err}; $k =~ s/[^a-z_]//g; | |
| 71 | my %h = ( | |
| 72 | bad_input => 'Missing or invalid input.', | |
| 73 | denied => 'You do not have permission for that action.', | |
| 74 | not_found => 'Buyer or storefront not found.', | |
| 75 | schema => 'The buyer credit ledger table is not installed yet.', | |
| 76 | ); | |
| 77 | $flash_msg = $h{$k} || 'Error.'; | |
| 78 | $flash_kind = 'danger'; | |
| 79 | } | |
| 80 | ||
| 81 | my $sid_in = defined $form->{sid} ? $form->{sid} : ''; | |
| 82 | $sid_in =~ s/[^0-9]//g; | |
| 83 | my $b_in = defined $form->{b} ? $form->{b} : ''; | |
| 84 | $b_in =~ s/[^0-9]//g; | |
| 85 | my $email_in = defined $form->{email} ? $form->{email} : ''; | |
| 86 | $email_in =~ s/^\s+|\s+$//g; | |
| 87 | $email_in = substr($email_in, 0, 191); | |
| 88 | ||
| 89 | # Map of storefront_id -> 1 for the seller's owned stores. Used to | |
| 90 | # authorize ?sid= / ?b= queries (can't peek at someone else's customer). | |
| 91 | my %owned_sid; | |
| 92 | { | |
| 93 | my @sf = $db->db_readwrite_multiple($dbh, qq~ | |
| 94 | SELECT id FROM `${DB}`.storefronts WHERE user_id='$owner_uid' | |
| 95 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 96 | $owned_sid{$_->{id}} = 1 foreach @sf; | |
| 97 | } | |
| 98 | ||
| 99 | # Storefront pick used for "Grant credit to any email" button. Default | |
| 100 | # to the first owned storefront when no ?sid is in URL. | |
| 101 | my $default_sid = 0; | |
| 102 | foreach my $id (sort { $a <=> $b } keys %owned_sid) { $default_sid = $id; last; } | |
| 103 | ||
| 104 | # ====== Detail view ====================================================== | |
| 105 | if ($sid_in && $owned_sid{$sid_in} && ($b_in || length $email_in)) { | |
| 106 | _render_detail($sid_in, $b_in, $email_in); | |
| 107 | exit; | |
| 108 | } | |
| 109 | ||
| 110 | # ====== List view ======================================================== | |
| 111 | _render_list(); | |
| 112 | exit; | |
| 113 | ||
| 114 | # ---------------------------------------------------------------------- | |
| 115 | sub _render_list { | |
| 116 | # Aggregate orders to get one row per buyer per storefront. | |
| 117 | # We pull buyer_email as the canonical identity (every order has one) | |
| 118 | # and join buyer_accounts to surface the display name when registered. | |
| 119 | my @rows; | |
| 120 | if (keys %owned_sid) { | |
| 121 | my $sid_list = join(',', map { "'$_'" } keys %owned_sid); | |
| 122 | @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 123 | SELECT o.storefront_id, | |
| 124 | o.buyer_email, | |
| 125 | MAX(o.buyer_account_id) AS buyer_account_id, | |
| 126 | COUNT(*) AS order_count, | |
| 127 | SUM(CASE WHEN o.status='paid' THEN o.total_amount_cents ELSE 0 END) AS spent_cents, | |
| 128 | MAX(o.created_at) AS last_order_at, | |
| 129 | s.name AS store_name, | |
| 130 | ba.display_name AS display_name | |
| 131 | FROM `${DB}`.orders o | |
| 132 | JOIN `${DB}`.storefronts s ON s.id = o.storefront_id | |
| 133 | LEFT JOIN `${DB}`.buyer_accounts ba | |
| 134 | ON ba.id = o.buyer_account_id | |
| 135 | WHERE o.storefront_id IN ($sid_list) | |
| 136 | GROUP BY o.storefront_id, o.buyer_email, s.name, ba.display_name | |
| 137 | ORDER BY last_order_at DESC | |
| 138 | LIMIT 500 | |
| 139 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 140 | } | |
| 141 | ||
| 142 | my @list; | |
| 143 | foreach my $r (@rows) { | |
| 144 | my $bal = 0; | |
| 145 | if ($r->{buyer_account_id}) { | |
| 146 | $bal = $bc->balance_cents($db, $dbh, $DB, $r->{storefront_id}, | |
| 147 | { buyer_account_id => $r->{buyer_account_id} }); | |
| 148 | } else { | |
| 149 | $bal = $bc->balance_cents($db, $dbh, $DB, $r->{storefront_id}, | |
| 150 | { buyer_email => $r->{buyer_email} }); | |
| 151 | } | |
| 152 | ||
| 153 | my $detail_qs = $r->{buyer_account_id} | |
| 154 | ? "sid=$r->{storefront_id}&b=$r->{buyer_account_id}" | |
| 155 | : "sid=$r->{storefront_id}&email=" . _u($r->{buyer_email}); | |
| 156 | ||
| 157 | push @list, { | |
| 158 | store_name => _h($r->{store_name}), | |
| 159 | storefront_id => $r->{storefront_id} + 0, | |
| 160 | buyer_email => _h($r->{buyer_email}), | |
| 161 | display_name => _h($r->{display_name} || ''), | |
| 162 | has_account => $r->{buyer_account_id} ? 1 : 0, | |
| 163 | order_count => $r->{order_count} + 0, | |
| 164 | spent_dollars => '$' . sprintf('%.2f', ($r->{spent_cents} || 0)/100), | |
| 165 | last_order_at => $r->{last_order_at} || '-', | |
| 166 | balance_dollars => ($bal < 0 ? '-' : '') . '$' . sprintf('%.2f', abs($bal)/100), | |
| 167 | balance_cents => $bal + 0, | |
| 168 | has_credit => $bal > 0 ? 1 : 0, | |
| 169 | no_credit => $bal == 0 ? 1 : 0, | |
| 170 | has_debit => $bal < 0 ? 1 : 0, | |
| 171 | detail_qs => $detail_qs, | |
| 172 | }; | |
| 173 | } | |
| 174 | ||
| 175 | $db->db_disconnect($dbh); | |
| 176 | ||
| 177 | my $tvars = { | |
| 178 | rows => \@list, | |
| 179 | has_rows => scalar(@list) ? 1 : 0, | |
| 180 | no_rows => scalar(@list) ? 0 : 1, | |
| 181 | can_grant => $can_grant, | |
| 182 | default_sid => $default_sid + 0, | |
| 183 | flash_msg => $flash_msg, | |
| 184 | flash_kind => $flash_kind, | |
| 185 | has_flash => length $flash_msg ? 1 : 0, | |
| 186 | is_list_view => 1, | |
| 187 | is_detail_view => 0, | |
| 188 | }; | |
| 189 | ||
| 190 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; | |
| 191 | my $body = join('', $tfile->template('repricer_customers.html', $tvars, $userinfo)); | |
| 192 | $wrap->render({ | |
| 193 | userinfo => $userinfo, | |
| 194 | page_key => 'customers', | |
| 195 | title => 'Customers', | |
| 196 | body => $body, | |
| 197 | }); | |
| 198 | } | |
| 199 | ||
| 200 | # ---------------------------------------------------------------------- | |
| 201 | sub _render_detail { | |
| 202 | my ($sid, $bid, $email) = @_; | |
| 203 | ||
| 204 | my $store = $db->db_readwrite($dbh, qq~ | |
| 205 | SELECT id, name FROM `${DB}`.storefronts WHERE id='$sid' LIMIT 1 | |
| 206 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 207 | unless ($store && $store->{id}) { | |
| 208 | $db->db_disconnect($dbh); | |
| 209 | print "Status: 302 Found\nLocation: /customers.cgi?err=not_found\n\n"; | |
| 210 | return; | |
| 211 | } | |
| 212 | ||
| 213 | # Resolve the buyer. Either we have a buyer_accounts.id, or we | |
| 214 | # only have an email (guest checkout case). | |
| 215 | my $buyer = { display_name => '', email => $email, has_account => 0, id => 0 }; | |
| 216 | if ($bid) { | |
| 217 | my $b = $db->db_readwrite($dbh, qq~ | |
| 218 | SELECT id, email, display_name, lifetime_value_cents, order_count, | |
| 219 | created_at, last_login_at | |
| 220 | FROM `${DB}`.buyer_accounts | |
| 221 | WHERE id='$bid' AND storefront_id='$sid' LIMIT 1 | |
| 222 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 223 | unless ($b && $b->{id}) { | |
| 224 | $db->db_disconnect($dbh); | |
| 225 | print "Status: 302 Found\nLocation: /customers.cgi?err=not_found\n\n"; | |
| 226 | return; | |
| 227 | } | |
| 228 | $buyer = { | |
| 229 | id => $b->{id} + 0, | |
| 230 | email => $b->{email}, | |
| 231 | display_name => $b->{display_name} || '', | |
| 232 | has_account => 1, | |
| 233 | lifetime_dollars => '$' . sprintf('%.2f', ($b->{lifetime_value_cents} || 0)/100), | |
| 234 | order_count => $b->{order_count} + 0, | |
| 235 | joined_at => $b->{created_at} || '-', | |
| 236 | last_login_at=> $b->{last_login_at} || 'Never', | |
| 237 | }; | |
| 238 | } else { | |
| 239 | # Guest path: also synthesize lifetime_value / order_count from orders. | |
| 240 | my $esc = $email; $esc =~ s/'/''/g; | |
| 241 | my $r = $db->db_readwrite($dbh, qq~ | |
| 242 | SELECT COUNT(*) AS n, | |
| 243 | SUM(CASE WHEN status='paid' THEN total_amount_cents ELSE 0 END) AS spent | |
| 244 | FROM `${DB}`.orders | |
| 245 | WHERE storefront_id='$sid' AND buyer_email='$esc' | |
| 246 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 247 | $buyer->{order_count} = $r ? ($r->{n} + 0) : 0; | |
| 248 | $buyer->{lifetime_dollars} = '$' . sprintf('%.2f', (($r ? $r->{spent} : 0) || 0)/100); | |
| 249 | $buyer->{joined_at} = '-'; | |
| 250 | $buyer->{last_login_at} = 'Never (guest checkout)'; | |
| 251 | } | |
| 252 | ||
| 253 | # Orders. Only SELECT store_credit_applied_cents when the schema | |
| 254 | # migration has run -- otherwise the column is absent and the | |
| 255 | # query would crash at the DBConnect layer. | |
| 256 | my @orders; | |
| 257 | { | |
| 258 | my $esc = $buyer->{email}; $esc =~ s/'/''/g; | |
| 259 | my $where = $buyer->{id} | |
| 260 | ? "buyer_account_id='$buyer->{id}'" | |
| 261 | : "buyer_account_id IS NULL AND buyer_email='$esc'"; | |
| 262 | my $credit_col = $bc->schema_ready($db, $dbh, $DB) | |
| 263 | ? 'store_credit_applied_cents' | |
| 264 | : '0 AS store_credit_applied_cents'; | |
| 265 | @orders = $db->db_readwrite_multiple($dbh, qq~ | |
| 266 | SELECT id, total_amount_cents, currency, status, created_at, | |
| 267 | $credit_col | |
| 268 | FROM `${DB}`.orders | |
| 269 | WHERE storefront_id='$sid' AND $where | |
| 270 | ORDER BY created_at DESC | |
| 271 | LIMIT 50 | |
| 272 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 273 | } | |
| 274 | my @order_rows; | |
| 275 | foreach my $o (@orders) { | |
| 276 | my $credit_used = $o->{store_credit_applied_cents} || 0; | |
| 277 | push @order_rows, { | |
| 278 | id => $o->{id} + 0, | |
| 279 | placed_at => $o->{created_at} || '-', | |
| 280 | status => $o->{status}, | |
| 281 | status_label => ucfirst($o->{status} || 'pending'), | |
| 282 | is_paid => $o->{status} eq 'paid' ? 1 : 0, | |
| 283 | is_refunded => ($o->{status} eq 'refunded' || $o->{status} eq 'partially_refunded') ? 1 : 0, | |
| 284 | total_dollars => '$' . sprintf('%.2f', ($o->{total_amount_cents} || 0)/100), | |
| 285 | credit_used_dollars => $credit_used > 0 ? ('$' . sprintf('%.2f', $credit_used/100)) : '', | |
| 286 | has_credit_used => $credit_used > 0 ? 1 : 0, | |
| 287 | }; | |
| 288 | } | |
| 289 | ||
| 290 | # Credit history. | |
| 291 | my @hist = $bc->history($db, $dbh, $DB, $sid, | |
| 292 | ($buyer->{id} ? { buyer_account_id => $buyer->{id} } : { buyer_email => $buyer->{email} }), 100); | |
| 293 | my @hist_rows; | |
| 294 | foreach my $h (@hist) { | |
| 295 | my $a = $h->{amount_cents} || 0; | |
| 296 | my %label = ( | |
| 297 | manual_grant => 'Goodwill grant', | |
| 298 | order_refund => 'Refund as credit', | |
| 299 | promotional => 'Promotional', | |
| 300 | order_apply => 'Used on order', | |
| 301 | reversal => 'Reversed (order refunded)', | |
| 302 | ); | |
| 303 | push @hist_rows, { | |
| 304 | id => $h->{id} + 0, | |
| 305 | amount_dollars => ($a < 0 ? '-' : '+') . '$' . sprintf('%.2f', abs($a)/100), | |
| 306 | is_positive => $a > 0 ? 1 : 0, | |
| 307 | is_negative => $a < 0 ? 1 : 0, | |
| 308 | reason => $h->{reason}, | |
| 309 | reason_label => $label{$h->{reason}} || $h->{reason}, | |
| 310 | related_order_id => $h->{related_order_id} ? ($h->{related_order_id} + 0) : 0, | |
| 311 | has_related => $h->{related_order_id} ? 1 : 0, | |
| 312 | note => _h($h->{note} || ''), | |
| 313 | created_at => $h->{created_at} || '-', | |
| 314 | }; | |
| 315 | } | |
| 316 | ||
| 317 | my $balance = $bc->balance_cents($db, $dbh, $DB, $sid, | |
| 318 | ($buyer->{id} ? { buyer_account_id => $buyer->{id} } : { buyer_email => $buyer->{email} })); | |
| 319 | ||
| 320 | $db->db_disconnect($dbh); | |
| 321 | ||
| 322 | my $tvars = { | |
| 323 | is_list_view => 0, | |
| 324 | is_detail_view => 1, | |
| 325 | can_grant => $can_grant, | |
| 326 | flash_msg => $flash_msg, | |
| 327 | flash_kind => $flash_kind, | |
| 328 | has_flash => length $flash_msg ? 1 : 0, | |
| 329 | ||
| 330 | store_id => $store->{id} + 0, | |
| 331 | store_name => _h($store->{name}), | |
| 332 | ||
| 333 | buyer_id => $buyer->{id} + 0, | |
| 334 | buyer_email => _h($buyer->{email}), | |
| 335 | buyer_name => _h($buyer->{display_name} || $buyer->{email}), | |
| 336 | buyer_has_account => $buyer->{has_account} ? 1 : 0, | |
| 337 | buyer_no_account => $buyer->{has_account} ? 0 : 1, | |
| 338 | buyer_lifetime => $buyer->{lifetime_dollars}, | |
| 339 | buyer_order_count => $buyer->{order_count}, | |
| 340 | buyer_joined => $buyer->{joined_at}, | |
| 341 | buyer_last_login => $buyer->{last_login_at}, | |
| 342 | ||
| 343 | balance_cents => $balance + 0, | |
| 344 | balance_dollars => ($balance < 0 ? '-' : '') . '$' . sprintf('%.2f', abs($balance)/100), | |
| 345 | has_credit => $balance > 0 ? 1 : 0, | |
| 346 | no_credit => $balance == 0 ? 1 : 0, | |
| 347 | has_debit => $balance < 0 ? 1 : 0, | |
| 348 | ||
| 349 | orders => \@order_rows, | |
| 350 | has_orders => scalar(@order_rows) ? 1 : 0, | |
| 351 | no_orders => scalar(@order_rows) ? 0 : 1, | |
| 352 | ||
| 353 | history => \@hist_rows, | |
| 354 | has_history => scalar(@hist_rows) ? 1 : 0, | |
| 355 | no_history => scalar(@hist_rows) ? 0 : 1, | |
| 356 | }; | |
| 357 | ||
| 358 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; | |
| 359 | my $body = join('', $tfile->template('repricer_customers.html', $tvars, $userinfo)); | |
| 360 | $wrap->render({ | |
| 361 | userinfo => $userinfo, | |
| 362 | page_key => 'customers', | |
| 363 | title => 'Customer: ' . ($buyer->{display_name} || $buyer->{email}), | |
| 364 | body => $body, | |
| 365 | }); | |
| 366 | } | |
| 367 | ||
| 368 | sub _h { | |
| 369 | my $s = shift; $s = '' unless defined $s; | |
| 370 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 371 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 372 | return $s; | |
| 373 | } | |
| 374 | sub _u { | |
| 375 | my $s = shift; $s = '' unless defined $s; | |
| 376 | $s =~ s/([^A-Za-z0-9\-_.~])/sprintf('%%%02X', ord($1))/eg; | |
| 377 | return $s; | |
| 378 | } |