added on local at 2026-07-01 21:47:34
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # RePricer - Seller-side Orders list (refundable actions). | |
| 4 | # | |
| 5 | # GET /orders.cgi | |
| 6 | # | |
| 7 | # Shows the most recent paid orders across all storefronts owned by | |
| 8 | # the signed-in seller. Each row exposes a Refund button (full refund | |
| 9 | # via Stripe) gated by the `refund_orders` ptag -- owners always pass, | |
| 10 | # team members need the explicit grant. | |
| 11 | # | |
| 12 | # Detailed analytics live at /sales_reports.cgi; this page is the | |
| 13 | # "I need to refund order #1247 right now" surface. | |
| 14 | #====================================================================== | |
| 15 | use strict; | |
| 16 | use warnings; | |
| 17 | ||
| 18 | use lib '/var/www/vhosts/3dshawn.com/repricer.3dshawn.com'; | |
| 19 | use CGI; | |
| 20 | use MODS::Template; | |
| 21 | use MODS::DBConnect; | |
| 22 | use MODS::Login; | |
| 23 | use MODS::RePricer::Config; | |
| 24 | use MODS::RePricer::Wrapper; | |
| 25 | use MODS::RePricer::Permissions; | |
| 26 | ||
| 27 | my $q = CGI->new; | |
| 28 | my $form = $q->Vars; | |
| 29 | my $auth = MODS::Login->new; | |
| 30 | my $wrap = MODS::RePricer::Wrapper->new; | |
| 31 | my $tfile = MODS::Template->new; | |
| 32 | my $db = MODS::DBConnect->new; | |
| 33 | my $cfg = MODS::RePricer::Config->new; | |
| 34 | my $perm = MODS::RePricer::Permissions->new; | |
| 35 | my $DB = $cfg->settings('database_name'); | |
| 36 | ||
| 37 | $|=1; | |
| 38 | my $userinfo = $auth->login_verify(); | |
| 39 | unless ($userinfo) { | |
| 40 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 41 | exit; | |
| 42 | } | |
| 43 | # View requires view_orders (covers owner + most preset roles); refund | |
| 44 | # button is shown only to those with refund_orders. Both checks are | |
| 45 | # owner-friendly via has_feature's owner short-circuit. | |
| 46 | $perm->require_feature($userinfo, 'view_orders'); | |
| 47 | ||
| 48 | my $uid = $userinfo->{user_id}; | |
| 49 | $uid =~ s/[^0-9]//g; | |
| 50 | my $can_refund = $perm->has_feature($userinfo, 'refund_orders') ? 1 : 0; | |
| 51 | ||
| 52 | # Resolve effective owner -- a team member sees their owner's stores. | |
| 53 | my $owner_uid = $userinfo->{owner_user_id} || $uid; | |
| 54 | $owner_uid =~ s/[^0-9]//g; | |
| 55 | ||
| 56 | my $dbh = $db->db_connect(); | |
| 57 | ||
| 58 | # Flash from orders_action.cgi redirects. | |
| 59 | my $flash_msg = ''; | |
| 60 | my $flash_kind = ''; | |
| 61 | if (defined $form->{refund_ok}) { | |
| 62 | my $oid = $form->{refund_ok}; $oid =~ s/[^0-9]//g; | |
| 63 | $flash_kind = 'ok'; | |
| 64 | $flash_msg = "Refund processed for order #$oid."; | |
| 65 | } | |
| 66 | if (defined $form->{refund_err}) { | |
| 67 | my $err = $form->{refund_err}; | |
| 68 | $err =~ s/[^A-Za-z0-9 .,;:_\-\$()%']//g; | |
| 69 | $err = substr($err, 0, 200); | |
| 70 | my %human = ( | |
| 71 | bad_act => 'Unknown action.', | |
| 72 | missing_id => 'No order id supplied.', | |
| 73 | not_found => 'Order not found.', | |
| 74 | denied => 'You do not have permission to refund this order.', | |
| 75 | not_paid => 'Only paid orders can be refunded.', | |
| 76 | over_total => 'Refund amount exceeds the order total.', | |
| 77 | stripe_unconfigured => 'Stripe is not configured. Add keys in Software Configuration first.', | |
| 78 | ); | |
| 79 | $flash_kind = 'danger'; | |
| 80 | $flash_msg = $human{$err} || ('Refund failed: ' . $err); | |
| 81 | } | |
| 82 | if (defined $form->{credit_ok}) { | |
| 83 | my $oid = $form->{credit_ok}; $oid =~ s/[^0-9]//g; | |
| 84 | $flash_kind = 'ok'; | |
| 85 | $flash_msg = "Store credit granted for order #$oid."; | |
| 86 | } | |
| 87 | if (defined $form->{credit_err}) { | |
| 88 | my $err = $form->{credit_err}; | |
| 89 | $err =~ s/[^A-Za-z0-9 .,;:_\-\$()%']//g; | |
| 90 | $err = substr($err, 0, 200); | |
| 91 | my %human = ( | |
| 92 | bad_input => 'Missing or invalid input.', | |
| 93 | not_found => 'Order not found.', | |
| 94 | denied => 'You do not have permission to credit this buyer.', | |
| 95 | schema => 'The buyer credit ledger is not installed yet -- run the DB migration first.', | |
| 96 | grant_failed=> 'Could not write the credit ledger row.', | |
| 97 | ); | |
| 98 | $flash_kind = 'danger'; | |
| 99 | $flash_msg = $human{$err} || ('Credit failed: ' . $err); | |
| 100 | } | |
| 101 | if (defined $form->{ship_ok}) { | |
| 102 | my $oid = $form->{ship_ok}; $oid =~ s/[^0-9]//g; | |
| 103 | $flash_kind = 'ok'; | |
| 104 | $flash_msg = "Marked shipped on order #$oid."; | |
| 105 | } | |
| 106 | if (defined $form->{ship_err}) { | |
| 107 | my $err = $form->{ship_err}; $err =~ s/[^A-Za-z0-9_\-]//g; | |
| 108 | my %human = ( | |
| 109 | missing_id => 'No item id supplied.', | |
| 110 | missing_tracking => 'Tracking carrier + number are required.', | |
| 111 | not_found => 'Order item not found.', | |
| 112 | denied => 'You do not have permission to fulfill this order.', | |
| 113 | not_physical => 'That item is digital -- nothing to ship.', | |
| 114 | ); | |
| 115 | $flash_kind = 'danger'; | |
| 116 | $flash_msg = $human{$err} || ('Mark-shipped failed: ' . $err); | |
| 117 | } | |
| 118 | ||
| 119 | # Probe whether the new shipping / per-line variant columns exist | |
| 120 | # on this install. Lets the page degrade to legacy display on a | |
| 121 | # server that hasn't run the physical-products migration yet. | |
| 122 | my $have_ship_cols = 0; | |
| 123 | { | |
| 124 | my $r = $db->db_readwrite($dbh, qq~ | |
| 125 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 126 | WHERE table_schema='$DB' AND table_name='orders' | |
| 127 | AND column_name='requires_shipping' | |
| 128 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 129 | $have_ship_cols = 1 if $r && $r->{n}; | |
| 130 | } | |
| 131 | my $have_oi_variant_cols = 0; | |
| 132 | { | |
| 133 | my $r = $db->db_readwrite($dbh, qq~ | |
| 134 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 135 | WHERE table_schema='$DB' AND table_name='order_items' | |
| 136 | AND column_name='purchase_kind' | |
| 137 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 138 | $have_oi_variant_cols = 1 if $r && $r->{n}; | |
| 139 | } | |
| 140 | ||
| 141 | # Recent orders across all storefronts this seller owns. Annual / | |
| 142 | # month bucketing happens on sales_reports.cgi; this page is the | |
| 143 | # operational list. | |
| 144 | my $LIMIT = 50; | |
| 145 | my $ship_select = $have_ship_cols ? q~ | |
| 146 | o.requires_shipping, o.shipping_cents, o.shipping_zone, | |
| 147 | o.ship_name, o.ship_addr1, o.ship_addr2, o.ship_city, | |
| 148 | o.ship_region, o.ship_postal, o.ship_country, o.ship_phone,~ : ''; | |
| 149 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 150 | SELECT o.id, o.status, o.total_amount_cents, o.currency, | |
| 151 | o.buyer_email, o.created_at, o.paid_at, | |
| 152 | o.stripe_payment_intent_id, | |
| 153 | $ship_select | |
| 154 | DATE_FORMAT(o.created_at, '%b %e, %Y %H:%i') AS placed_at, | |
| 155 | s.name AS store_name, s.id AS store_id | |
| 156 | FROM `${DB}`.orders o | |
| 157 | JOIN `${DB}`.storefronts s ON s.id = o.storefront_id | |
| 158 | WHERE s.user_id='$owner_uid' | |
| 159 | ORDER BY o.created_at DESC | |
| 160 | LIMIT $LIMIT | |
| 161 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 162 | ||
| 163 | # Per-line fulfillment for the visible orders. One query, indexed | |
| 164 | # in Perl by order_id so the render loop is O(1) per row. | |
| 165 | my %lines_by_order; | |
| 166 | if ($have_oi_variant_cols && @rows) { | |
| 167 | my @ids = map { $_->{id} } @rows; | |
| 168 | my $id_in = join(',', map { "'$_'" } @ids); | |
| 169 | # Probe for bundle_id column. | |
| 170 | my $oi_has_bundle = 0; | |
| 171 | { | |
| 172 | my $pr = $db->db_readwrite($dbh, qq~ | |
| 173 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 174 | WHERE table_schema='$DB' AND table_name='order_items' | |
| 175 | AND column_name='bundle_id' | |
| 176 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 177 | $oi_has_bundle = 1 if $pr && $pr->{n}; | |
| 178 | } | |
| 179 | my $bsel = $oi_has_bundle ? q~oi.bundle_id, b.title AS bundle_title,~ : q~NULL AS bundle_id, NULL AS bundle_title,~; | |
| 180 | my $bjoin = $oi_has_bundle ? qq~LEFT JOIN \`${DB}\`.bundles b ON b.id = oi.bundle_id~ : ''; | |
| 181 | my @ls = $db->db_readwrite_multiple($dbh, qq~ | |
| 182 | SELECT oi.id, oi.order_id, oi.model_id, oi.quantity, | |
| 183 | oi.purchase_kind, oi.selected_color, oi.selected_material, | |
| 184 | oi.fulfillment_status, oi.tracking_carrier, | |
| 185 | oi.tracking_number, oi.shipped_at, | |
| 186 | $bsel | |
| 187 | m.title AS m_title | |
| 188 | FROM `${DB}`.order_items oi | |
| 189 | LEFT JOIN `${DB}`.models m ON m.id = oi.model_id | |
| 190 | $bjoin | |
| 191 | WHERE oi.order_id IN ($id_in) | |
| 192 | ORDER BY oi.id ASC | |
| 193 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 194 | foreach my $l (@ls) { | |
| 195 | $l->{title} = $l->{bundle_id} | |
| 196 | ? ($l->{bundle_title} || 'Bundle') | |
| 197 | : ($l->{m_title} || ('Model #' . ($l->{model_id} || '?'))); | |
| 198 | } | |
| 199 | foreach my $l (@ls) { | |
| 200 | push @{ $lines_by_order{$l->{order_id}} }, $l; | |
| 201 | } | |
| 202 | } | |
| 203 | ||
| 204 | $db->db_disconnect($dbh); | |
| 205 | ||
| 206 | my %FUL_LABEL = ( | |
| 207 | not_required => 'Digital -- no shipping', | |
| 208 | pending => 'Awaiting print', | |
| 209 | printing => 'Printing', | |
| 210 | shipped => 'Shipped', | |
| 211 | delivered => 'Delivered', | |
| 212 | canceled => 'Canceled', | |
| 213 | ); | |
| 214 | ||
| 215 | my @order_rows; | |
| 216 | foreach my $r (@rows) { | |
| 217 | my $st = $r->{status} || 'pending'; | |
| 218 | ||
| 219 | # Per-line fulfillment data for this order. | |
| 220 | my @lines; | |
| 221 | foreach my $l (@{ $lines_by_order{$r->{id}} || [] }) { | |
| 222 | my $kind = $l->{purchase_kind} || 'digital'; | |
| 223 | my $fs = $l->{fulfillment_status} || ($kind eq 'physical' ? 'pending' : 'not_required'); | |
| 224 | my @variant_bits; | |
| 225 | push @variant_bits, _h($l->{selected_color}) if $l->{selected_color}; | |
| 226 | push @variant_bits, _h($l->{selected_material}) if $l->{selected_material}; | |
| 227 | push @lines, { | |
| 228 | id => $l->{id}, | |
| 229 | title => _h($l->{title}), | |
| 230 | quantity => $l->{quantity} || 1, | |
| 231 | kind => $kind, | |
| 232 | is_physical => ($kind eq 'physical') ? 1 : 0, | |
| 233 | variant_pill => scalar(@variant_bits) ? join(' · ', @variant_bits) : '', | |
| 234 | fulfillment => $fs, | |
| 235 | fulfillment_label => $FUL_LABEL{$fs} || ucfirst($fs), | |
| 236 | can_mark_shipped => ($kind eq 'physical' && $fs ne 'shipped' && $fs ne 'delivered' && $fs ne 'canceled' && $st eq 'paid') ? 1 : 0, | |
| 237 | is_shipped => ($fs eq 'shipped' || $fs eq 'delivered') ? 1 : 0, | |
| 238 | tracking_carrier=> _h($l->{tracking_carrier} || ''), | |
| 239 | tracking_number => _h($l->{tracking_number} || ''), | |
| 240 | }; | |
| 241 | } | |
| 242 | ||
| 243 | # Shipping address summary -- single string + flag. | |
| 244 | my $ship_addr = ''; | |
| 245 | if ($have_ship_cols && $r->{requires_shipping}) { | |
| 246 | my @addr_lines = grep { defined && length } | |
| 247 | (_h($r->{ship_name} || ''), | |
| 248 | _h($r->{ship_addr1} || ''), | |
| 249 | _h($r->{ship_addr2} || ''), | |
| 250 | join(', ', grep { length } (_h($r->{ship_city} || ''), _h($r->{ship_region} || ''), _h($r->{ship_postal} || ''))), | |
| 251 | _h($r->{ship_country} || '')); | |
| 252 | $ship_addr = join('<br>', grep { length } @addr_lines); | |
| 253 | } | |
| 254 | my $ship_cents = $r->{shipping_cents} || 0; | |
| 255 | ||
| 256 | push @order_rows, { | |
| 257 | id => $r->{id}, | |
| 258 | placed_at => $r->{placed_at}, | |
| 259 | store_name => _h($r->{store_name}), | |
| 260 | buyer_email => _h($r->{buyer_email} || '(no email)'), | |
| 261 | total_amount_cents => $r->{total_amount_cents} || 0, | |
| 262 | total_display => '$' . sprintf('%.2f', ($r->{total_amount_cents} || 0) / 100), | |
| 263 | status => $st, | |
| 264 | status_label => ucfirst($st), | |
| 265 | is_paid => $st eq 'paid' ? 1 : 0, | |
| 266 | is_pending => $st eq 'pending' ? 1 : 0, | |
| 267 | is_failed => $st eq 'failed' ? 1 : 0, | |
| 268 | is_refunded => ($st eq 'refunded' || $st eq 'partially_refunded') ? 1 : 0, | |
| 269 | # Refundable = paid OR partially-refunded (further partial refund) AND has a Stripe PI | |
| 270 | # AND the caller holds refund_orders. Free orders without a PI are also refundable in | |
| 271 | # the orders_action.cgi flow (just marks the row); show the button if status is paid. | |
| 272 | can_refund_now => ($can_refund && ($st eq 'paid' || $st eq 'partially_refunded')) ? 1 : 0, | |
| 273 | ||
| 274 | # Physical-fulfillment surfaces. | |
| 275 | requires_shipping => ($have_ship_cols && $r->{requires_shipping}) ? 1 : 0, | |
| 276 | ship_address_html => $ship_addr, | |
| 277 | ship_phone => _h($r->{ship_phone} || ''), | |
| 278 | ship_zone => _h($r->{shipping_zone} || ''), | |
| 279 | ship_cost_display => '$' . sprintf('%.2f', $ship_cents / 100), | |
| 280 | lines => \@lines, | |
| 281 | has_lines => scalar(@lines) ? 1 : 0, | |
| 282 | }; | |
| 283 | } | |
| 284 | ||
| 285 | my $tvars = { | |
| 286 | user_id => $uid, | |
| 287 | orders => \@order_rows, | |
| 288 | has_orders => scalar(@order_rows) ? 1 : 0, | |
| 289 | no_orders => scalar(@order_rows) ? 0 : 1, | |
| 290 | can_refund => $can_refund, | |
| 291 | flash_msg => $flash_msg, | |
| 292 | flash_kind => $flash_kind, | |
| 293 | has_flash => length $flash_msg ? 1 : 0, | |
| 294 | }; | |
| 295 | ||
| 296 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; | |
| 297 | ||
| 298 | my $body = join('', $tfile->template('repricer_orders.html', $tvars, $userinfo)); | |
| 299 | ||
| 300 | $wrap->render({ | |
| 301 | userinfo => $userinfo, | |
| 302 | page_key => 'orders', | |
| 303 | title => 'Orders', | |
| 304 | body => $body, | |
| 305 | }); | |
| 306 | ||
| 307 | sub _h { | |
| 308 | my $s = shift; $s = '' unless defined $s; | |
| 309 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 310 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 311 | return $s; | |
| 312 | } |