added on local at 2026-07-01 15:03:02
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # ContactForge - Stripe webhook handler. | |
| 4 | # | |
| 5 | # Endpoint: POST /stripe_webhook.cgi | |
| 6 | # | |
| 7 | # Stripe POSTs JSON with a Stripe-Signature header. We verify the | |
| 8 | # signature against stripe_webhook_secret (read from /private/stripe.conf | |
| 9 | # via Config.pm) before parsing the event. | |
| 10 | # | |
| 11 | # Events handled: | |
| 12 | # payment_intent.succeeded -> route on metadata.kind: | |
| 13 | # 'subscription_invoice' -> mark invoice paid | |
| 14 | # otherwise -> mark order paid + log conversion | |
| 15 | # payment_intent.payment_failed -> same routing as succeeded, opposite outcome | |
| 16 | # charge.refunded -> mark order refunded (or partial) | |
| 17 | # account.updated -> bump stripe_onboarded_at if charges_enabled | |
| 18 | # | |
| 19 | # We always respond 200 OK so Stripe doesn't retry; failures are logged | |
| 20 | # server-side. Stripe's docs explicitly recommend this pattern. | |
| 21 | #====================================================================== | |
| 22 | use strict; | |
| 23 | use warnings; | |
| 24 | ||
| 25 | use lib '/var/www/vhosts/3dshawn.com/crm.3dshawn.com'; | |
| 26 | use CGI; | |
| 27 | use JSON::PP; | |
| 28 | use MODS::DBConnect; | |
| 29 | use MODS::ContactForge::Config; | |
| 30 | use MODS::ContactForge::Stripe; | |
| 31 | use MODS::ContactForge::Billing; | |
| 32 | ||
| 33 | use MODS::ContactForge::NoOp; | |
| 34 | $| = 1; | |
| 35 | ||
| 36 | sub _ok { | |
| 37 | print "Status: 200 OK\nContent-Type: text/plain\n\nok\n"; | |
| 38 | exit; | |
| 39 | } | |
| 40 | sub _esc { | |
| 41 | my $s = shift // ''; | |
| 42 | $s =~ s/\\/\\\\/g; | |
| 43 | $s =~ s/'/''/g; | |
| 44 | return $s; | |
| 45 | } | |
| 46 | ||
| 47 | # Read raw body from STDIN. CGI->new touches STDIN already, so we read | |
| 48 | # it ourselves before constructing CGI for headers. | |
| 49 | my $raw_body; | |
| 50 | { | |
| 51 | local $/; | |
| 52 | $raw_body = <STDIN> // ''; | |
| 53 | } | |
| 54 | ||
| 55 | my $sig = $ENV{HTTP_STRIPE_SIGNATURE} || ''; | |
| 56 | my $stripe = MODS::ContactForge::Stripe->new; | |
| 57 | unless ($stripe->is_configured) { | |
| 58 | # No keys yet -- swallow the request rather than 500ing so Stripe | |
| 59 | # doesn't keep retrying during the bootstrap phase. | |
| 60 | _ok(); | |
| 61 | } | |
| 62 | unless ($stripe->verify_webhook($raw_body, $sig)) { | |
| 63 | print "Status: 400 Bad Request\nContent-Type: text/plain\n\nbad signature\n"; | |
| 64 | exit; | |
| 65 | } | |
| 66 | ||
| 67 | my $event; | |
| 68 | eval { $event = JSON::PP::decode_json($raw_body); 1 } or _ok(); | |
| 69 | my $type = $event->{type} || ''; | |
| 70 | my $obj = $event->{data}{object} || {}; | |
| 71 | ||
| 72 | my $db = MODS::DBConnect->new; | |
| 73 | my $cfg = MODS::ContactForge::Config->new; | |
| 74 | my $DB = $cfg->settings('database_name'); | |
| 75 | my $dbh = $db->db_connect(); | |
| 76 | ||
| 77 | if ($type eq 'payment_intent.succeeded') { | |
| 78 | # Subscription-invoice PI: created by Billing::charge_invoice -> | |
| 79 | # Stripe::create_subscription_charge with metadata.kind set. Handle | |
| 80 | # here and short-circuit so the order branch never tries to look up | |
| 81 | # an order id that does not exist. | |
| 82 | my $kind_meta = $obj->{metadata}{kind} || ''; | |
| 83 | if ($kind_meta eq 'subscription_invoice') { | |
| 84 | my $invoice_id = $obj->{metadata}{invoice_id} || ''; | |
| 85 | $invoice_id =~ s/[^0-9]//g; | |
| 86 | my $pi_id_sub = $obj->{id} || ''; | |
| 87 | $pi_id_sub =~ s/[^A-Za-z0-9_]//g; | |
| 88 | my $amt = $obj->{amount_received} || $obj->{amount} || 0; | |
| 89 | if ($invoice_id) { | |
| 90 | my $bill = MODS::ContactForge::Billing->new; | |
| 91 | $bill->mark_invoice_paid($db, $dbh, $DB, $invoice_id, | |
| 92 | cash_paid_cents => $amt, | |
| 93 | stripe_payment_intent_id => $pi_id_sub, | |
| 94 | ); | |
| 95 | } | |
| 96 | $db->db_disconnect($dbh); | |
| 97 | _ok(); | |
| 98 | } | |
| 99 | ||
| 100 | my $pi_id = $obj->{id} || ''; | |
| 101 | my $oid_meta = $obj->{metadata}{order_id} || ''; | |
| 102 | $pi_id =~ s/'/''/g; | |
| 103 | $oid_meta =~ s/[^0-9]//g; | |
| 104 | ||
| 105 | # Resolve the order. Prefer metadata.order_id (created at intent | |
| 106 | # time) and fall back to the unique stripe_payment_intent_id index. | |
| 107 | # Pull applied_promotion_id + discount_applied_cents so we can write | |
| 108 | # the matching promotion_redemptions row below. | |
| 109 | my $order; | |
| 110 | if ($oid_meta) { | |
| 111 | $order = $db->db_readwrite($dbh, qq~ | |
| 112 | SELECT id, dashboard_id, contact_email, status, | |
| 113 | contact_account_id, applied_promotion_id, discount_applied_cents | |
| 114 | FROM `${DB}`.orders WHERE id='$oid_meta' LIMIT 1 | |
| 115 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 116 | } | |
| 117 | if (!$order && $pi_id) { | |
| 118 | $order = $db->db_readwrite($dbh, qq~ | |
| 119 | SELECT id, dashboard_id, contact_email, status, | |
| 120 | contact_account_id, applied_promotion_id, discount_applied_cents | |
| 121 | FROM `${DB}`.orders WHERE stripe_payment_intent_id='$pi_id' LIMIT 1 | |
| 122 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 123 | } | |
| 124 | ||
| 125 | if ($order && $order->{id} && $order->{status} ne 'paid') { | |
| 126 | my $oid = $order->{id}; | |
| 127 | $db->db_readwrite($dbh, qq~ | |
| 128 | UPDATE `${DB}`.orders | |
| 129 | SET status='paid', paid_at=NOW() | |
| 130 | WHERE id='$oid' | |
| 131 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 132 | ||
| 133 | # Promo redemption -- write only on payment success, never on | |
| 134 | # pending/failed, so a declined card doesn't burn the contact's | |
| 135 | # max_per_user slot. The discount is already baked into | |
| 136 | # total_amount_cents; this row is the audit trail + bump for | |
| 137 | # the promo's redemption counter. | |
| 138 | if ($order->{applied_promotion_id} && $order->{applied_promotion_id} > 0) { | |
| 139 | my $promo_mod = MODS::ContactForge::NoOp->new; | |
| 140 | $promo_mod->redeem($db, $dbh, $DB, | |
| 141 | promotion_id => $order->{applied_promotion_id}, | |
| 142 | target_kind => 'model', | |
| 143 | order_id => $oid, | |
| 144 | contact_account_id => $order->{contact_account_id}, | |
| 145 | contact_email => $order->{contact_email}, | |
| 146 | discount_applied_cents => $order->{discount_applied_cents} || 0, | |
| 147 | ); | |
| 148 | } | |
| 149 | ||
| 150 | # If a contact_account exists for this email, retroactively link | |
| 151 | # the order so the contact can see it on /my_orders.cgi. | |
| 152 | my $email = $order->{contact_email} || ''; | |
| 153 | my $sid = $order->{dashboard_id} || 0; | |
| 154 | if ($email && $sid) { | |
| 155 | my $ba = $db->db_readwrite($dbh, qq~ | |
| 156 | SELECT id FROM `${DB}`.contact_accounts | |
| 157 | WHERE dashboard_id='$sid' AND email='~ . _esc($email) . qq~' | |
| 158 | LIMIT 1 | |
| 159 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 160 | if ($ba && $ba->{id}) { | |
| 161 | $db->db_readwrite($dbh, qq~ | |
| 162 | UPDATE `${DB}`.orders SET contact_account_id='$ba->{id}' | |
| 163 | WHERE id='$oid' AND contact_account_id IS NULL | |
| 164 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 165 | } | |
| 166 | } | |
| 167 | ||
| 168 | # Log a conversion event for any running A/B experiments. The | |
| 169 | # visitor hash isn't on the order row -- experiments tie events | |
| 170 | # to visitor_hash, so we look it up from the cart token chain. | |
| 171 | # For now we log a generic 'purchase' event with the order's | |
| 172 | # total dollar amount tied to the most recent visitor view. | |
| 173 | my $total_dollars = ($obj->{amount} || 0) / 100; | |
| 174 | my $vh = $db->db_readwrite($dbh, qq~ | |
| 175 | SELECT visitor_hash FROM `${DB}`.view_events | |
| 176 | WHERE dashboard_id='$sid' | |
| 177 | ORDER BY occurred_at DESC LIMIT 1 | |
| 178 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 179 | my $visitor_hash = ($vh && $vh->{visitor_hash}) ? $vh->{visitor_hash} : ''; | |
| 180 | if ($visitor_hash) { | |
| 181 | eval { | |
| 182 | my $exp = MODS::ContactForge::NoOp->new; | |
| 183 | $exp->log_event_for_visitor_experiments( | |
| 184 | $db, $dbh, $DB, $sid, $visitor_hash, 'purchase', $total_dollars | |
| 185 | ); | |
| 186 | }; | |
| 187 | } | |
| 188 | ||
| 189 | # Consume any store credit the contact authorized at checkout. | |
| 190 | # Idempotent on (related_order_id, reason='order_apply') so a | |
| 191 | # retried webhook is safe. apply_to_order reads | |
| 192 | # orders.store_credit_applied_cents as the source of truth. | |
| 193 | eval { | |
| 194 | my $bc = MODS::ContactForge::NoOp->new; | |
| 195 | $bc->apply_to_order($db, $dbh, $DB, $oid); | |
| 196 | }; | |
| 197 | ||
| 198 | # Decrement physical inventory for every order_items row whose | |
| 199 | # model has finite stock (inventory_qty >= 0). -1 = unlimited | |
| 200 | # print-to-order, so we leave it alone. UPDATE is bounded by | |
| 201 | # `inventory_qty > 0` to prevent the count from going negative | |
| 202 | # on a retried webhook (idempotent). Guarded by an | |
| 203 | # information_schema probe so legacy installs without the | |
| 204 | # variant columns don't crash. | |
| 205 | eval { | |
| 206 | my $oi_has_kind = $db->db_readwrite($dbh, qq~ | |
| 207 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 208 | WHERE table_schema='$DB' AND table_name='order_items' | |
| 209 | AND column_name='purchase_kind' | |
| 210 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 211 | if ($oi_has_kind && $oi_has_kind->{n}) { | |
| 212 | my @lines = $db->db_readwrite_multiple($dbh, qq~ | |
| 213 | SELECT model_id, quantity FROM `${DB}`.order_items | |
| 214 | WHERE order_id='$oid' AND purchase_kind='physical' | |
| 215 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 216 | foreach my $ln (@lines) { | |
| 217 | my $mid = $ln->{model_id}; $mid =~ s/[^0-9]//g; next unless $mid; | |
| 218 | my $qty = $ln->{quantity}; $qty =~ s/[^0-9]//g; $qty ||= 1; | |
| 219 | $db->db_readwrite($dbh, qq~ | |
| 220 | UPDATE `${DB}`.models | |
| 221 | SET inventory_qty = GREATEST(inventory_qty - $qty, 0) | |
| 222 | WHERE id='$mid' AND inventory_qty >= 0 | |
| 223 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 224 | } | |
| 225 | } | |
| 226 | }; | |
| 227 | ||
| 228 | # Send the contact their receipt email with signed download | |
| 229 | # links. Wrapped in eval -- a mailer failure (no SMTP, MTA | |
| 230 | # down) must never block the webhook from returning 200, or | |
| 231 | # Stripe will retry and we'd double-process the order. The | |
| 232 | # send_for_order method itself is also defensive: bails on | |
| 233 | # missing config and prints to STDERR. | |
| 234 | eval { | |
| 235 | MODS::ContactForge::Receipts->send_for_order($db, $dbh, $DB, $oid); | |
| 236 | }; | |
| 237 | } | |
| 238 | } | |
| 239 | elsif ($type eq 'payment_intent.payment_failed') { | |
| 240 | my $kind_meta = $obj->{metadata}{kind} || ''; | |
| 241 | if ($kind_meta eq 'subscription_invoice') { | |
| 242 | my $invoice_id = $obj->{metadata}{invoice_id} || ''; | |
| 243 | $invoice_id =~ s/[^0-9]//g; | |
| 244 | my $pi_id_sub = $obj->{id} || ''; | |
| 245 | $pi_id_sub =~ s/[^A-Za-z0-9_]//g; | |
| 246 | my $err = ($obj->{last_payment_error} && $obj->{last_payment_error}{message}) | |
| 247 | ? $obj->{last_payment_error}{message} | |
| 248 | : 'Card declined.'; | |
| 249 | if ($invoice_id) { | |
| 250 | my $bill = MODS::ContactForge::Billing->new; | |
| 251 | $bill->mark_invoice_failed($db, $dbh, $DB, $invoice_id, | |
| 252 | reason => $err, | |
| 253 | stripe_payment_intent_id => $pi_id_sub, | |
| 254 | ); | |
| 255 | } | |
| 256 | $db->db_disconnect($dbh); | |
| 257 | _ok(); | |
| 258 | } | |
| 259 | ||
| 260 | my $pi_id = $obj->{id} || ''; | |
| 261 | $pi_id =~ s/'/''/g; | |
| 262 | $db->db_readwrite($dbh, qq~ | |
| 263 | UPDATE `${DB}`.orders | |
| 264 | SET status='failed' | |
| 265 | WHERE stripe_payment_intent_id='$pi_id' AND status='pending' | |
| 266 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 267 | } | |
| 268 | elsif ($type eq 'charge.refunded') { | |
| 269 | my $pi_id = $obj->{payment_intent} || ''; | |
| 270 | $pi_id =~ s/'/''/g; | |
| 271 | if ($pi_id) { | |
| 272 | my $amount_refunded = $obj->{amount_refunded} || 0; | |
| 273 | my $amount = $obj->{amount} || 0; | |
| 274 | my $new_status = ($amount_refunded >= $amount) ? 'refunded' : 'partially_refunded'; | |
| 275 | # Find the order before we update status so we can pass the id | |
| 276 | # to ContactCredits->reverse_for_order on full refunds. | |
| 277 | my $ord = $db->db_readwrite($dbh, qq~ | |
| 278 | SELECT id FROM `${DB}`.orders | |
| 279 | WHERE stripe_payment_intent_id='$pi_id' LIMIT 1 | |
| 280 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 281 | $db->db_readwrite($dbh, qq~ | |
| 282 | UPDATE `${DB}`.orders | |
| 283 | SET status='$new_status' | |
| 284 | WHERE stripe_payment_intent_id='$pi_id' | |
| 285 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 286 | # Full refund: return any consumed contact credit to the contact's | |
| 287 | # ledger. Partial refund is messier (which line item was | |
| 288 | # refunded?); we skip the reversal for now to avoid silently | |
| 289 | # over-crediting. | |
| 290 | if ($ord && $ord->{id} && $new_status eq 'refunded') { | |
| 291 | eval { | |
| 292 | my $bc = MODS::ContactForge::NoOp->new; | |
| 293 | $bc->reverse_for_order($db, $dbh, $DB, $ord->{id}); | |
| 294 | }; | |
| 295 | } | |
| 296 | } | |
| 297 | } | |
| 298 | elsif ($type eq 'checkout.session.completed') { | |
| 299 | # Contact's subscription signup completed in Stripe Checkout. Match | |
| 300 | # back to contact_subscriptions via metadata.contact_subscription_id, | |
| 301 | # then activate + attach the stripe ids. | |
| 302 | my $mode = $obj->{mode} || ''; | |
| 303 | if ($mode eq 'subscription') { | |
| 304 | my $sub_id = $obj->{metadata}{contact_subscription_id} || 0; | |
| 305 | my $cust = $obj->{customer} || ''; | |
| 306 | my $stripe_sub = $obj->{subscription} || ''; | |
| 307 | $sub_id =~ s/[^0-9]//g; | |
| 308 | for ($cust, $stripe_sub) { s/'/''/g; } | |
| 309 | if ($sub_id) { | |
| 310 | require MODS::ContactForge::Subscriptions; | |
| 311 | my $sm = MODS::ContactForge::Subscriptions->new; | |
| 312 | $db->db_readwrite($dbh, qq~ | |
| 313 | UPDATE `${DB}`.contact_subscriptions | |
| 314 | SET stripe_customer_id = '$cust', | |
| 315 | stripe_subscription_id = '$stripe_sub' | |
| 316 | WHERE id='$sub_id' LIMIT 1 | |
| 317 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 318 | $sm->activate_from_stripe($db, $dbh, $DB, | |
| 319 | contact_sub_id => $sub_id, | |
| 320 | stripe_customer_id => $cust, | |
| 321 | ); | |
| 322 | } | |
| 323 | } | |
| 324 | } | |
| 325 | elsif ($type eq 'invoice.paid' || $type eq 'invoice.payment_succeeded') { | |
| 326 | # Recurring renewal succeeded. Roll the period on the matching | |
| 327 | # contact_subscriptions row. | |
| 328 | my $stripe_sub = $obj->{subscription} || ''; | |
| 329 | if ($stripe_sub) { | |
| 330 | require MODS::ContactForge::Subscriptions; | |
| 331 | my $sm = MODS::ContactForge::Subscriptions->new; | |
| 332 | my $bs = $sm->by_stripe_subscription_id($db, $dbh, $DB, $stripe_sub); | |
| 333 | if ($bs && $bs->{id}) { | |
| 334 | $sm->activate_from_stripe($db, $dbh, $DB, | |
| 335 | contact_sub_id => $bs->{id}, | |
| 336 | ); | |
| 337 | } | |
| 338 | } | |
| 339 | } | |
| 340 | elsif ($type eq 'invoice.payment_failed') { | |
| 341 | my $stripe_sub = $obj->{subscription} || ''; | |
| 342 | if ($stripe_sub) { | |
| 343 | my $esc = $stripe_sub; $esc =~ s/'/''/g; | |
| 344 | $db->db_readwrite($dbh, qq~ | |
| 345 | UPDATE `${DB}`.contact_subscriptions | |
| 346 | SET status='past_due' | |
| 347 | WHERE stripe_subscription_id='$esc' LIMIT 1 | |
| 348 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 349 | } | |
| 350 | } | |
| 351 | elsif ($type eq 'customer.subscription.deleted' | |
| 352 | || $type eq 'customer.subscription.canceled') { | |
| 353 | my $stripe_sub = $obj->{id} || ''; | |
| 354 | if ($stripe_sub) { | |
| 355 | my $esc = $stripe_sub; $esc =~ s/'/''/g; | |
| 356 | $db->db_readwrite($dbh, qq~ | |
| 357 | UPDATE `${DB}`.contact_subscriptions | |
| 358 | SET status='canceled', canceled_at=NOW() | |
| 359 | WHERE stripe_subscription_id='$esc' LIMIT 1 | |
| 360 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 361 | } | |
| 362 | } | |
| 363 | elsif ($type eq 'account.updated') { | |
| 364 | my $acct_id = $obj->{id} || ''; | |
| 365 | $acct_id =~ s/'/''/g; | |
| 366 | my $charges_enabled = $obj->{charges_enabled} ? 1 : 0; | |
| 367 | my $details_done = $obj->{details_submitted} ? 1 : 0; | |
| 368 | if ($acct_id && $charges_enabled && $details_done) { | |
| 369 | $db->db_readwrite($dbh, qq~ | |
| 370 | UPDATE `${DB}`.dashboards | |
| 371 | SET stripe_onboarded_at=COALESCE(stripe_onboarded_at, NOW()) | |
| 372 | WHERE stripe_account_id='$acct_id' | |
| 373 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 374 | } | |
| 375 | } | |
| 376 | ||
| 377 | $db->db_disconnect($dbh); | |
| 378 | _ok(); |