added on local at 2026-07-01 21:47:32
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # RePricer -- Seller actions against a customer (buyer) record. | |
| 4 | # | |
| 5 | # POST /customer_action.cgi | |
| 6 | # act=grant_credit | |
| 7 | # storefront_id=S -- must be owned by the caller (or their owner) | |
| 8 | # buyer_account_id=N -- preferred (registered buyer) | |
| 9 | # buyer_email=... -- required if buyer_account_id is missing | |
| 10 | # amount_cents=N -- positive integer (cents) | |
| 11 | # note=... -- shown to buyer in their credit history | |
| 12 | # return_to=URL -- same-site absolute path; default /customers.cgi | |
| 13 | # | |
| 14 | # Authorization: requires the `refund_orders` ptag (granting store | |
| 15 | # credit is conceptually a soft refund). Storefront ownership is | |
| 16 | # verified before the ledger write. | |
| 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::DBConnect; | |
| 24 | use MODS::Login; | |
| 25 | use MODS::RePricer::Config; | |
| 26 | use MODS::RePricer::Permissions; | |
| 27 | use MODS::RePricer::BuyerCredits; | |
| 28 | ||
| 29 | $|=1; | |
| 30 | ||
| 31 | my $q = CGI->new; | |
| 32 | my $form = $q->Vars; | |
| 33 | my $auth = MODS::Login->new; | |
| 34 | my $db = MODS::DBConnect->new; | |
| 35 | my $cfg = MODS::RePricer::Config->new; | |
| 36 | my $perm = MODS::RePricer::Permissions->new; | |
| 37 | my $bc = MODS::RePricer::BuyerCredits->new; | |
| 38 | my $DB = $cfg->settings('database_name'); | |
| 39 | ||
| 40 | my $userinfo = $auth->login_verify(); | |
| 41 | unless ($userinfo) { | |
| 42 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 43 | exit; | |
| 44 | } | |
| 45 | ||
| 46 | my $return_to = defined $form->{return_to} ? $form->{return_to} : '/customers.cgi'; | |
| 47 | $return_to = '/customers.cgi' unless $return_to =~ m{^/[^/]} || $return_to eq '/'; | |
| 48 | ||
| 49 | sub _go { | |
| 50 | my ($qs) = @_; | |
| 51 | my $sep = ($return_to =~ /\?/) ? '&' : '?'; | |
| 52 | print "Status: 302 Found\nLocation: $return_to$sep$qs\n\n"; | |
| 53 | exit; | |
| 54 | } | |
| 55 | ||
| 56 | unless (($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 57 | _go('err=bad_input'); | |
| 58 | } | |
| 59 | ||
| 60 | my $act = defined $form->{act} ? $form->{act} : ''; | |
| 61 | _go('err=bad_input') unless $act eq 'grant_credit'; | |
| 62 | ||
| 63 | my $caller_uid = $userinfo->{user_id}; | |
| 64 | $caller_uid =~ s/[^0-9]//g; | |
| 65 | my $owner_uid = $userinfo->{owner_user_id} || $caller_uid; | |
| 66 | $owner_uid =~ s/[^0-9]//g; | |
| 67 | ||
| 68 | unless ($perm->has_feature($userinfo, 'refund_orders')) { | |
| 69 | _go('err=denied'); | |
| 70 | } | |
| 71 | ||
| 72 | my $sid = defined $form->{storefront_id} ? $form->{storefront_id} : ''; | |
| 73 | $sid =~ s/[^0-9]//g; | |
| 74 | _go('err=bad_input') unless $sid; | |
| 75 | ||
| 76 | my $bid = defined $form->{buyer_account_id} ? $form->{buyer_account_id} : ''; | |
| 77 | $bid =~ s/[^0-9]//g; | |
| 78 | ||
| 79 | my $email = defined $form->{buyer_email} ? $form->{buyer_email} : ''; | |
| 80 | $email =~ s/^\s+|\s+$//g; | |
| 81 | $email = substr($email, 0, 191); | |
| 82 | ||
| 83 | _go('err=bad_input') unless $bid || ($email =~ /\@/ && $email =~ /\./); | |
| 84 | ||
| 85 | my $amt = defined $form->{amount_cents} ? $form->{amount_cents} : ''; | |
| 86 | $amt =~ s/[^0-9]//g; | |
| 87 | _go('err=bad_input') unless $amt && $amt > 0; | |
| 88 | ||
| 89 | my $note = defined $form->{note} ? $form->{note} : ''; | |
| 90 | $note =~ s/[\r\n]+/ /g; | |
| 91 | $note = substr($note, 0, 480); | |
| 92 | ||
| 93 | my $dbh = $db->db_connect(); | |
| 94 | ||
| 95 | # Authorize storefront ownership. Platform admins always pass. | |
| 96 | my $is_admin = $userinfo->{is_admin} ? 1 : 0; | |
| 97 | unless ($is_admin) { | |
| 98 | my $owns = $db->db_readwrite($dbh, qq~ | |
| 99 | SELECT id FROM `${DB}`.storefronts | |
| 100 | WHERE id='$sid' AND user_id='$owner_uid' LIMIT 1 | |
| 101 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 102 | unless ($owns && $owns->{id}) { | |
| 103 | $db->db_disconnect($dbh); | |
| 104 | _go('err=denied'); | |
| 105 | } | |
| 106 | } | |
| 107 | ||
| 108 | unless ($bc->schema_ready($db, $dbh, $DB)) { | |
| 109 | $db->db_disconnect($dbh); | |
| 110 | _go('err=schema'); | |
| 111 | } | |
| 112 | ||
| 113 | # If buyer_account_id is given, verify it actually belongs to this | |
| 114 | # storefront -- otherwise a malicious admin could credit a buyer of | |
| 115 | # a different storefront via crafted POST. | |
| 116 | if ($bid) { | |
| 117 | my $ba = $db->db_readwrite($dbh, qq~ | |
| 118 | SELECT id, email FROM `${DB}`.buyer_accounts | |
| 119 | WHERE id='$bid' AND storefront_id='$sid' LIMIT 1 | |
| 120 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 121 | unless ($ba && $ba->{id}) { | |
| 122 | $db->db_disconnect($dbh); | |
| 123 | _go('err=not_found'); | |
| 124 | } | |
| 125 | # Use the canonical email from buyer_accounts so a follow-up guest | |
| 126 | # checkout (no session) under the same email finds the credit. | |
| 127 | $email = $ba->{email} unless length $email; | |
| 128 | } | |
| 129 | ||
| 130 | my $new_id = $bc->grant($db, $dbh, $DB, | |
| 131 | storefront_id => $sid, | |
| 132 | buyer_account_id => $bid || undef, | |
| 133 | buyer_email => $email, | |
| 134 | amount_cents => $amt, | |
| 135 | reason => 'manual_grant', | |
| 136 | granted_by_user_id => $caller_uid, | |
| 137 | note => $note, | |
| 138 | ); | |
| 139 | ||
| 140 | $db->db_disconnect($dbh); | |
| 141 | ||
| 142 | _go($new_id ? 'ok=credit_granted' : 'err=credit_failed'); |