Diff -- /var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/Billing.pm
Diff

/var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/Billing.pm

added on local at 2026-07-01 22:09:36

Added
+2275
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to a12e193f1287
Restore this content →
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.
1package MODS::ShopCart::Billing;
2#======================================================================
3# ShopCart - Recurring billing + credit ledger helper.
4#
5# Centralizes every read/write against the billing tables:
6# billing_plans, subscriptions, invoices, invoice_items,
7# payment_methods, credit_ledger.
8#
9# Credit-system invariant: a user is NEVER charged real money until
10# their credit balance is exhausted. invoice generation always:
11# 1. computes credit_balance (SUM(credit_ledger.amount_cents))
12# 2. sets credit_applied = MIN(amount_due, credit_balance)
13# 3. sets cash_due = amount_due - credit_applied
14# 4. writes the negative -applied credit_ledger row in the same pass.
15#
16# Every method that queries one of these tables guards with
17# `SHOW TABLES LIKE` first because DBConnect's error() calls exit() --
18# matches feedback_guard_optional_tables.
19#======================================================================
20use strict;
21use warnings;
22
23sub new {
24 my ($class, %args) = @_;
25 my $self = bless({}, $class);
26 return $self;
27}
28
29# ---- Canonical feature catalog --------------------------------------
30# These are the entitlement keys an admin can attach to a plan, and
31# the same keys the profile.cgi "Available Features" tab gates on.
32# Edit this list to add a new feature; the admin Packages UI picks it
33# up automatically and the profile UI renders it as a row.
34#
35# `module` is the wrapper sidebar key used to surface the matching
36# nav link in the upgrade CTA. `default_for` is the lowest tier that
37# *should* have it on a fresh install (used only for seeding).
38my @FEATURE_CATALOG = (
39 { key => 'publishing',
40 name => 'Publishing',
41 blurb => 'Cross-platform sync, queue, per-marketplace overrides',
42 details => 'Lets the seller push their models to external marketplaces (Cults3D, MyMiniFactory, etc.) from a single console. When this is OFF, the Marketplaces sidebar entry is hidden and the publish action on /upload_model.cgi rejects with an upgrade prompt.',
43 enforced_in => 'Sidebar (marketplaces), /upload_model.cgi, /update_listing.cgi',
44 icon => 'send',
45 module => 'marketplaces' },
46 { key => 'storefront',
47 name => 'Storefront',
48 blurb => 'Branded store, checkout, page builder',
49 details => 'Unlocks the seller\'s public storefront -- a subdomain.shop.3dshawn.com page with their models, checkout via Stripe Connect, and the in-place page editor. When OFF, /store.cgi shows a "this storefront isn\'t live" notice and the seller can\'t edit hero copy, themes, or layout.',
50 enforced_in => 'Sidebar (My Storefront), /store.cgi, /storefront.cgi, /update_storefront_field.cgi',
51 icon => 'store',
52 module => 'storefront' },
53 { key => 'optimization',
54 name => 'Optimization',
55 blurb => 'A/B, MVT, price tests, surveys',
56 details => 'Gives the seller access to experiments on their storefront -- price A/B tests, MVT layouts, on-page surveys, and conversion tracking against control. When OFF, /optimization.cgi 403s and the Optimization sidebar item is hidden.',
57 enforced_in => 'Sidebar (Optimization), /optimization.cgi',
58 icon => 'activity',
59 module => 'optimize' },
60 { key => 'analytics',
61 name => 'Analytics',
62 blurb => 'Cross-platform performance + benchmarks',
63 details => 'Unlocks Sales Reports and the cross-platform performance dashboards (revenue, conversion, marketplace-by-marketplace breakdowns). When OFF, the Reporting section in the sidebar is hidden and the seller falls back to a single-storefront view.',
64 enforced_in => 'Sidebar (Sales Reports / Traffic Statistics / Heatmaps), /sales_reports.cgi, /traffic_reports.cgi',
65 icon => 'chart',
66 module => 'analytics' },
67 { key => 'audience',
68 name => 'Audience',
69 blurb => 'Buyer accounts, email lists, comments inbox',
70 details => 'Turns on buyer accounts (sign-in for the seller\'s customers), email-list capture, comment moderation, and the messages inbox. When OFF, /messages.cgi 403s and storefront pages render in "checkout only" mode without buyer sign-up.',
71 enforced_in => 'Sidebar (Messages), /messages.cgi, buyer signup on storefront',
72 icon => 'people',
73 module => 'audience' },
74);
75
76sub feature_catalog { return @FEATURE_CATALOG; }
77
78sub feature_by_key {
79 my ($self, $key) = @_;
80 foreach my $f (@FEATURE_CATALOG) {
81 return $f if $f->{key} eq ($key || '');
82 }
83 return undef;
84}
85
86# ---- Schema readiness ------------------------------------------------
87# Returns 1 only if every billing table is present. Callers render an
88# empty/awaiting state when this is 0 instead of running queries.
89sub schema_ready {
90 my ($self, $db, $dbh, $DB) = @_;
91 foreach my $t (qw(billing_plans subscriptions invoices invoice_items payment_methods credit_ledger)) {
92 my $r = $db->db_readwrite($dbh, qq~
93 SELECT COUNT(*) AS n FROM information_schema.tables
94 WHERE table_schema='$DB' AND table_name='$t'
95 ~, $ENV{SCRIPT_NAME}, __LINE__);
96 return 0 unless ($r && $r->{n});
97 }
98 return 1;
99}
100
101# Has the plan_features entitlement table been migrated yet? Pricing,
102# settings, and admin Packages all gate their feature lookups on this
103# so they degrade cleanly to "no entitlements known" pre-migration.
104sub plan_features_ready {
105 my ($self, $db, $dbh, $DB) = @_;
106 return $self->{_pf_ready} if exists $self->{_pf_ready};
107 my $r = $db->db_readwrite($dbh, qq~
108 SELECT COUNT(*) AS n FROM information_schema.tables
109 WHERE table_schema='$DB' AND table_name='plan_features'
110 ~, $ENV{SCRIPT_NAME}, __LINE__);
111 $self->{_pf_ready} = ($r && $r->{n}) ? 1 : 0;
112 return $self->{_pf_ready};
113}
114
115# Has the columns added in the Packages migration landed? Same idea --
116# admin Packages reads these, but pricing.cgi keeps working without
117# them. We probe once and cache.
118sub plan_columns_ready {
119 my ($self, $db, $dbh, $DB) = @_;
120 return $self->{_pc_ready} if exists $self->{_pc_ready};
121 my $r = $db->db_readwrite($dbh, qq~
122 SELECT COUNT(*) AS n FROM information_schema.columns
123 WHERE table_schema='$DB' AND table_name='billing_plans'
124 AND column_name='is_featured'
125 ~, $ENV{SCRIPT_NAME}, __LINE__);
126 $self->{_pc_ready} = ($r && $r->{n}) ? 1 : 0;
127 return $self->{_pc_ready};
128}
129
130# ---- Plan catalog ----------------------------------------------------
131# Build SELECT column list -- includes admin-managed columns
132# (tagline / cta_label / is_featured) only when the Packages
133# migration has run. Pre-migration callers still get the base fields.
134sub _plan_select_cols {
135 my ($self, $db, $dbh, $DB) = @_;
136 my $base = q{id, tier, cadence, display_name, price_cents, currency,
137 yearly_mode, yearly_pct_off, yearly_off_cents, yearly_price_cents,
138 features, is_active, sort_order};
139 if ($self->plan_columns_ready($db, $dbh, $DB)) {
140 $base .= q{, tagline, cta_label, is_featured};
141 }
142 return $base;
143}
144
145# --------------------------------------------------------------
146# Compute the effective yearly price in cents for a plan row,
147# given the yearly_mode + the relevant input field. Returns 0
148# when the plan offers no yearly option (yearly_mode='none' or
149# monthly price is 0 -- e.g. the Free tier).
150# --------------------------------------------------------------
151sub compute_yearly_price_cents {
152 my ($self, $plan) = @_;
153 return 0 unless ref($plan) eq 'HASH';
154 my $monthly = int($plan->{price_cents} || 0);
155 return 0 if $monthly <= 0;
156 my $mode = $plan->{yearly_mode} || 'none';
157 if ($mode eq 'explicit') {
158 return int($plan->{yearly_price_cents} || 0);
159 }
160 if ($mode eq 'percent_off') {
161 my $pct = int($plan->{yearly_pct_off} || 0);
162 $pct = 0 if $pct < 0;
163 $pct = 90 if $pct > 90; # cap so we never end up under 10%
164 return int($monthly * 12 * (100 - $pct) / 100 + 0.5);
165 }
166 if ($mode eq 'dollars_off') {
167 my $off = int($plan->{yearly_off_cents} || 0);
168 my $p = $monthly * 12 - $off;
169 return $p > 0 ? $p : 0;
170 }
171 return 0; # 'none'
172}
173
174sub list_plans {
175 my ($self, $db, $dbh, $DB, $include_inactive) = @_;
176 return () unless $self->schema_ready($db, $dbh, $DB);
177
178 my $where = $include_inactive ? '' : 'WHERE is_active=1';
179 my $cols = $self->_plan_select_cols($db, $dbh, $DB);
180 my @rows = $db->db_readwrite_multiple($dbh, qq~
181 SELECT $cols
182 FROM `${DB}`.billing_plans
183 $where
184 ORDER BY sort_order ASC, id ASC
185 ~, $ENV{SCRIPT_NAME}, __LINE__);
186 return @rows;
187}
188
189sub plan_by_id {
190 my ($self, $db, $dbh, $DB, $plan_id) = @_;
191 $plan_id =~ s/[^0-9]//g if defined $plan_id;
192 return {} unless $plan_id;
193 return {} unless $self->schema_ready($db, $dbh, $DB);
194
195 my $cols = $self->_plan_select_cols($db, $dbh, $DB);
196 my $r = $db->db_readwrite($dbh, qq~
197 SELECT $cols
198 FROM `${DB}`.billing_plans
199 WHERE id='$plan_id'
200 LIMIT 1
201 ~, $ENV{SCRIPT_NAME}, __LINE__);
202 return ($r && $r->{id}) ? $r : {};
203}
204
205# ---- Plan -> feature entitlements -----------------------------------
206# Returns a hashref { feature_key => 1, ... } of features the given
207# plan includes. Empty hash if the table isn't migrated yet (callers
208# treat that as "no entitlements" -- effectively all features locked).
209sub plan_feature_set {
210 my ($self, $db, $dbh, $DB, $plan_id) = @_;
211 my %out;
212 $plan_id =~ s/[^0-9]//g if defined $plan_id;
213 return \%out unless $plan_id;
214 return \%out unless $self->plan_features_ready($db, $dbh, $DB);
215
216 my @rows = $db->db_readwrite_multiple($dbh, qq~
217 SELECT feature_key
218 FROM `${DB}`.plan_features
219 WHERE plan_id='$plan_id' AND is_included=1
220 ~, $ENV{SCRIPT_NAME}, __LINE__);
221 foreach my $r (@rows) { $out{ $r->{feature_key} } = 1; }
222 return \%out;
223}
224
225# Set the entitlements for a plan. $included_aref is a list of
226# feature_keys to mark included; every catalog key NOT in that list
227# is written as is_included=0. Caller is responsible for validating
228# that $plan_id refers to a real row.
229sub set_plan_features {
230 my ($self, $db, $dbh, $DB, $plan_id, $included_aref) = @_;
231 $plan_id =~ s/[^0-9]//g if defined $plan_id;
232 return 0 unless $plan_id;
233 return 0 unless $self->plan_features_ready($db, $dbh, $DB);
234
235 my %wanted = map { $_ => 1 } @{ $included_aref || [] };
236 foreach my $f ($self->feature_catalog) {
237 my $key = $f->{key};
238 my $inc = $wanted{$key} ? 1 : 0;
239 # REPLACE because PK is (plan_id, feature_key).
240 $db->db_readwrite($dbh, qq~
241 REPLACE INTO `${DB}`.plan_features
242 SET plan_id='$plan_id',
243 feature_key='$key',
244 is_included='$inc'
245 ~, $ENV{SCRIPT_NAME}, __LINE__);
246 }
247 return 1;
248}
249
250# True if the user's active subscription's plan includes the given
251# feature_key. Free-tier users still get features whose plan includes
252# them. If no subscription row exists at all we still honor the Free
253# plan's entitlements (lowest sort_order, price_cents=0).
254sub user_has_feature {
255 my ($self, $db, $dbh, $DB, $uid, $feature_key) = @_;
256 $uid =~ s/[^0-9]//g if defined $uid;
257 return 0 unless $uid && $feature_key;
258 return 0 unless $self->plan_features_ready($db, $dbh, $DB);
259
260 my $sub = $self->active_subscription($db, $dbh, $DB, $uid);
261 my $plan_id = $sub->{plan_id};
262 if (!$plan_id) {
263 # Fall back to the lowest-priced active plan (Free seat).
264 my $r = $db->db_readwrite($dbh, qq~
265 SELECT id FROM `${DB}`.billing_plans
266 WHERE is_active=1
267 ORDER BY price_cents ASC, sort_order ASC
268 LIMIT 1
269 ~, $ENV{SCRIPT_NAME}, __LINE__);
270 $plan_id = ($r && $r->{id}) ? $r->{id} : 0;
271 }
272 return 0 unless $plan_id;
273
274 my $set = $self->plan_feature_set($db, $dbh, $DB, $plan_id);
275 return $set->{$feature_key} ? 1 : 0;
276}
277
278# Returns the full feature catalog rolled up with the user's current
279# entitlement state, for rendering on profile.cgi. Each row:
280# { key, name, blurb, icon, module, included (0/1), plan_label }
281sub user_feature_entitlements {
282 my ($self, $db, $dbh, $DB, $uid) = @_;
283 $uid =~ s/[^0-9]//g if defined $uid;
284 my @out;
285
286 my $plan_label = 'Free';
287 my $plan_id = 0;
288 if ($uid && $self->schema_ready($db, $dbh, $DB)) {
289 my $sub = $self->active_subscription($db, $dbh, $DB, $uid);
290 if ($sub->{plan_id}) {
291 $plan_id = $sub->{plan_id};
292 $plan_label = $sub->{display_name} || ucfirst($sub->{tier} || 'Free');
293 } else {
294 my $r = $db->db_readwrite($dbh, qq~
295 SELECT id, display_name, tier FROM `${DB}`.billing_plans
296 WHERE is_active=1
297 ORDER BY price_cents ASC, sort_order ASC
298 LIMIT 1
299 ~, $ENV{SCRIPT_NAME}, __LINE__);
300 if ($r && $r->{id}) {
301 $plan_id = $r->{id};
302 $plan_label = $r->{display_name} || ucfirst($r->{tier} || 'Free');
303 }
304 }
305 }
306 my $set = $plan_id ? $self->plan_feature_set($db, $dbh, $DB, $plan_id) : {};
307
308 foreach my $f ($self->feature_catalog) {
309 push @out, {
310 key => $f->{key},
311 name => $f->{name},
312 blurb => $f->{blurb},
313 icon => $f->{icon},
314 module => $f->{module},
315 included => $set->{ $f->{key} } ? 1 : 0,
316 locked => $set->{ $f->{key} } ? 0 : 1,
317 plan_label => $plan_label,
318 };
319 }
320 return @out;
321}
322
323sub plan_by_tier_cadence {
324 my ($self, $db, $dbh, $DB, $tier, $cadence) = @_;
325 $cadence ||= 'monthly';
326 return {} unless $self->schema_ready($db, $dbh, $DB);
327
328 my %tier_ok = map { $_ => 1 } qw(free pro business);
329 my %cadence_ok = map { $_ => 1 } qw(monthly annual);
330 return {} unless $tier_ok{$tier} && $cadence_ok{$cadence};
331
332 # Post-consolidation: one row per tier. The requested cadence picks
333 # which price to surface as `price_cents`. For annual requests,
334 # compute_yearly_price_cents() resolves the percent/dollars/explicit
335 # mode; for monthly, we return the row's price_cents as-is.
336 my $r = $db->db_readwrite($dbh, qq~
337 SELECT id, tier, display_name, price_cents, currency,
338 yearly_mode, yearly_pct_off, yearly_off_cents, yearly_price_cents,
339 features
340 FROM `${DB}`.billing_plans
341 WHERE tier='$tier' AND is_active=1
342 LIMIT 1
343 ~, $ENV{SCRIPT_NAME}, __LINE__);
344 return {} unless $r && $r->{id};
345
346 $r->{cadence} = $cadence;
347 if ($cadence eq 'annual') {
348 my $yp = $self->compute_yearly_price_cents($r);
349 return {} unless $yp > 0; # tier offers no yearly upgrade
350 $r->{price_cents} = $yp;
351 }
352 return $r;
353}
354
355# ---- Subscription lookup --------------------------------------------
356# Returns the user's most-recently-modified non-canceled subscription
357# or {} if none. We always allow at most one active subscription per
358# user; downgrades/upgrades update the existing row rather than create
359# new ones, which keeps invoice history tied to a single sub_id.
360sub active_subscription {
361 my ($self, $db, $dbh, $DB, $uid) = @_;
362 $uid =~ s/[^0-9]//g;
363 return {} unless $uid;
364 return {} unless $self->schema_ready($db, $dbh, $DB);
365
366 # Pending-downgrade columns ship in a follow-on migration; guard
367 # so existing installs that haven't run the ALTER still load.
368 my $pend_cols = $self->_pending_cols_ready($db, $dbh, $DB)
369 ? ', s.pending_plan_id, s.pending_cadence, s.pending_change_at'
370 : '';
371
372 # `cadence` lives on the SUBSCRIPTION row (post-consolidation),
373 # not the plan. Returns the monthly base price; callers that need
374 # the yearly price for an annual sub should run the plan through
375 # compute_yearly_price_cents() themselves.
376 my $r = $db->db_readwrite($dbh, qq~
377 SELECT s.id, s.user_id, s.plan_id, s.cadence, s.status,
378 s.started_at, s.trial_end, s.next_invoice_at,
379 s.canceled_at, s.cancel_at_period_end,
380 s.last_charge_failed_at, s.last_charge_error$pend_cols,
381 p.tier, p.display_name, p.price_cents, p.currency, p.features,
382 p.yearly_mode, p.yearly_pct_off, p.yearly_off_cents, p.yearly_price_cents
383 FROM `${DB}`.subscriptions s
384 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
385 WHERE s.user_id='$uid'
386 AND s.status IN ('trialing','active','past_due','paused')
387 ORDER BY s.updated_at DESC
388 LIMIT 1
389 ~, $ENV{SCRIPT_NAME}, __LINE__);
390 return {} unless ($r && $r->{id});
391
392 # If a deferred change had a pending_plan attached, fetch the
393 # display_name / tier of the *target* plan so the UI can render
394 # "Scheduled to downgrade to Starter on 2026-06-12". One small
395 # query; only runs when an active pending change exists.
396 if ($pend_cols && $r->{pending_plan_id}) {
397 my $pp = $self->plan_by_id($db, $dbh, $DB, $r->{pending_plan_id});
398 if ($pp && $pp->{id}) {
399 $r->{pending_plan_display_name} = $pp->{display_name};
400 $r->{pending_plan_tier} = $pp->{tier};
401 $r->{pending_plan_price_cents} = $pp->{price_cents};
402 }
403 }
404 return $r;
405}
406
407# Cached probe for the pending-change columns on subscriptions. Cheap
408# (single information_schema row) and stable per request, so we stash
409# the result on $self and reuse for every active_subscription() call.
410sub _pending_cols_ready {
411 my ($self, $db, $dbh, $DB) = @_;
412 return $self->{_pend_ready} if exists $self->{_pend_ready};
413 my $r = $db->db_readwrite($dbh, qq~
414 SELECT COUNT(*) AS n FROM information_schema.columns
415 WHERE table_schema='$DB' AND table_name='subscriptions'
416 AND column_name='pending_plan_id'
417 ~, $ENV{SCRIPT_NAME}, __LINE__);
418 $self->{_pend_ready} = ($r && $r->{n}) ? 1 : 0;
419 return $self->{_pend_ready};
420}
421
422# Tier rank for upgrade-vs-downgrade comparisons. Higher = more
423# valuable. Anything outside the known set is treated as free (0) so
424# we never miscategorize a custom-tier slug as an upgrade.
425# Post-consolidation tiers: free / pro / business. Numeric gap between
426# pro and business is preserved (skip rank 1) so any caller doing
427# distance math still sees a multi-step jump for a tier change.
428sub tier_rank {
429 my ($self, $tier) = @_;
430 return 0 unless defined $tier;
431 return 3 if $tier eq 'business';
432 return 2 if $tier eq 'pro';
433 return 0; # free or unknown
434}
435
436# Decide whether moving from $cur_sub to $new_plan/$new_cadence is an
437# upgrade (apply now) or downgrade (defer to current cycle end). Same
438# tier + same cadence is a no-op. Returns one of: 'immediate',
439# 'deferred', 'noop'.
440sub _classify_plan_change {
441 my ($self, $cur_sub, $new_plan, $new_cadence) = @_;
442 return 'immediate' unless ($cur_sub && $cur_sub->{id});
443 my $cur_rank = $self->tier_rank($cur_sub->{tier} || 'free');
444 my $new_rank = $self->tier_rank($new_plan->{tier} || 'free');
445 return 'immediate' if $new_rank > $cur_rank;
446 return 'deferred' if $new_rank < $cur_rank;
447 # Same tier -- compare cadence. Monthly->annual is more cash up
448 # front => treat as upgrade. Annual->monthly is the cheaper cycle
449 # => defer so the seller gets what they paid for. Equal cadence
450 # on the same tier is a no-op (already on this plan).
451 my $cur_cad = $cur_sub->{cadence} || 'monthly';
452 my $new_cad = $new_cadence || $cur_cad;
453 return 'noop' if $new_cad eq $cur_cad;
454 return 'immediate' if $cur_cad eq 'monthly' && $new_cad eq 'annual';
455 return 'deferred';
456}
457
458# Public plan-change entry point. Called from billing_action.cgi.
459# Returns a hash:
460# { mode => 'immediate'|'deferred'|'noop'|'trial',
461# effective_at => 'YYYY-MM-DD HH:MM:SS' (deferred + trial),
462# new_tier => 'pro', new_plan_id => 5 }
463# Caller redirects with a flash describing what happened.
464#
465# Optional opts hash (4th positional after $new_cadence):
466# trial_days => N -- start the new plan in status='trialing' with
467# trial_end = NOW() + N days. next_invoice_at is
468# anchored to trial_end so the first invoice
469# arrives the moment the trial ends. Promotion
470# from trialing -> active happens automatically
471# in apply_pending_changes_if_due() / the
472# billing worker once trial_end <= NOW().
473sub change_plan {
474 my ($self, $db, $dbh, $DB, $uid, $new_plan_id, $new_cadence, %opts) = @_;
475 $uid =~ s/[^0-9]//g;
476 $new_plan_id =~ s/[^0-9]//g;
477 return { mode => 'noop' } unless $uid && $new_plan_id;
478 return { mode => 'noop' } unless $self->schema_ready($db, $dbh, $DB);
479
480 my $new_plan = $self->plan_by_id($db, $dbh, $DB, $new_plan_id);
481 return { mode => 'noop' } unless $new_plan && $new_plan->{id};
482
483 # Normalize cadence input. Default to current sub's cadence if the
484 # caller didn't supply one, falling back to monthly for fresh subs.
485 my $cur_sub = $self->active_subscription($db, $dbh, $DB, $uid);
486 $new_cadence ||= ($cur_sub && $cur_sub->{cadence}) ? $cur_sub->{cadence} : 'monthly';
487 $new_cadence = 'monthly' unless $new_cadence eq 'annual';
488
489 my $mode = $self->_classify_plan_change($cur_sub, $new_plan, $new_cadence);
490 my $tier = $new_plan->{tier} || 'free';
491
492 if ($mode eq 'noop') {
493 return { mode => 'noop', new_tier => $tier, new_plan_id => $new_plan_id };
494 }
495
496 # Trial mode: caller asked for a N-day trial on the new plan.
497 # Only valid as part of an "immediate" plan change -- you can't
498 # downgrade into a trial. We honor it when classify_plan_change
499 # says immediate; otherwise treat as a normal change.
500 my $trial_days = ($opts{trial_days} || 0) + 0;
501 $trial_days = 0 if $trial_days < 0;
502 $trial_days = 90 if $trial_days > 90; # ceiling to limit abuse
503
504 if ($mode eq 'immediate' && $trial_days > 0) {
505 # Trialing subscription: status='trialing', trial_end = now+N,
506 # next_invoice_at = trial_end. The worker promotes status to
507 # 'active' the moment trial_end passes (see
508 # apply_pending_changes_if_due + the explicit promotion query
509 # in _billing_worker.pl).
510 my $tier_local = $new_plan->{tier} || 'free';
511 if ($cur_sub && $cur_sub->{id}) {
512 my $sid = $cur_sub->{id};
513 $db->db_readwrite($dbh, qq~
514 UPDATE `${DB}`.subscriptions
515 SET plan_id='$new_plan_id',
516 cadence='$new_cadence',
517 status='trialing',
518 cancel_at_period_end=0,
519 trial_end=DATE_ADD(NOW(), INTERVAL $trial_days DAY),
520 next_invoice_at=DATE_ADD(NOW(), INTERVAL $trial_days DAY)
521 WHERE id='$sid' AND user_id='$uid'
522 ~, $ENV{SCRIPT_NAME}, __LINE__);
523 } else {
524 $db->db_readwrite($dbh, qq~
525 INSERT INTO `${DB}`.subscriptions
526 SET user_id='$uid',
527 plan_id='$new_plan_id',
528 cadence='$new_cadence',
529 status='trialing',
530 started_at=NOW(),
531 trial_end=DATE_ADD(NOW(), INTERVAL $trial_days DAY),
532 next_invoice_at=DATE_ADD(NOW(), INTERVAL $trial_days DAY)
533 ~, $ENV{SCRIPT_NAME}, __LINE__);
534 }
535 # Mirror onto users.plan_tier so feature gating activates
536 # right away during the trial -- the whole point of a trial
537 # is to let them USE the higher tier.
538 $db->db_readwrite($dbh, qq~
539 UPDATE `${DB}`.users SET plan_tier='$tier_local' WHERE id='$uid'
540 ~, $ENV{SCRIPT_NAME}, __LINE__);
541 my $eff = $db->db_readwrite($dbh, qq~
542 SELECT trial_end FROM `${DB}`.subscriptions WHERE user_id='$uid'
543 ORDER BY updated_at DESC LIMIT 1
544 ~, $ENV{SCRIPT_NAME}, __LINE__);
545 return {
546 mode => 'trial',
547 new_tier => $tier_local,
548 new_plan_id => $new_plan_id,
549 effective_at => ($eff && $eff->{trial_end}) ? $eff->{trial_end} : '',
550 trial_days => $trial_days,
551 };
552 }
553
554 if ($mode eq 'immediate') {
555 # Either upgrading or first-time sub. Swap plan_id now, advance
556 # next_invoice_at one period from today, and clear any pending
557 # downgrade that was queued before (an upgrade cancels the
558 # previously-scheduled downgrade -- the seller changed their
559 # mind).
560 my $interval = ($new_cadence eq 'annual') ? '1 YEAR' : '1 MONTH';
561 if ($cur_sub && $cur_sub->{id}) {
562 my $sid = $cur_sub->{id};
563 my $pend_clear = $self->_pending_cols_ready($db, $dbh, $DB)
564 ? ', pending_plan_id=NULL, pending_cadence=NULL, pending_change_at=NULL'
565 : '';
566 $db->db_readwrite($dbh, qq~
567 UPDATE `${DB}`.subscriptions
568 SET plan_id='$new_plan_id',
569 cadence='$new_cadence',
570 status='active',
571 cancel_at_period_end=0$pend_clear,
572 next_invoice_at=DATE_ADD(NOW(), INTERVAL $interval)
573 WHERE id='$sid' AND user_id='$uid'
574 ~, $ENV{SCRIPT_NAME}, __LINE__);
575 } else {
576 $db->db_readwrite($dbh, qq~
577 INSERT INTO `${DB}`.subscriptions
578 SET user_id='$uid',
579 plan_id='$new_plan_id',
580 cadence='$new_cadence',
581 status='active',
582 started_at=NOW(),
583 next_invoice_at=DATE_ADD(NOW(), INTERVAL $interval)
584 ~, $ENV{SCRIPT_NAME}, __LINE__);
585 }
586 $db->db_readwrite($dbh, qq~
587 UPDATE `${DB}`.users SET plan_tier='$tier' WHERE id='$uid'
588 ~, $ENV{SCRIPT_NAME}, __LINE__);
589 return { mode => 'immediate', new_tier => $tier, new_plan_id => $new_plan_id };
590 }
591
592 # Deferred: stash the target in pending_* and let the apply step
593 # flip plan_id when NOW() >= pending_change_at. We require the
594 # pending columns to be present; if not (existing install without
595 # the migration), fall back to immediate-but-warn so a downgrade
596 # still works rather than silently dropping.
597 unless ($self->_pending_cols_ready($db, $dbh, $DB)) {
598 return $self->_apply_immediate_change($db, $dbh, $DB, $uid, $cur_sub,
599 $new_plan_id, $new_cadence, $tier, _fallback => 1);
600 }
601 my $sid = $cur_sub->{id};
602 my $effective = $cur_sub->{next_invoice_at};
603 # If the sub somehow has no next_invoice_at, anchor one period
604 # from now so the downgrade still has a deterministic apply time.
605 unless ($effective) {
606 my $interval = ($cur_sub->{cadence} || 'monthly') eq 'annual' ? '1 YEAR' : '1 MONTH';
607 $db->db_readwrite($dbh, qq~
608 UPDATE `${DB}`.subscriptions
609 SET next_invoice_at=DATE_ADD(NOW(), INTERVAL $interval)
610 WHERE id='$sid' AND user_id='$uid'
611 ~, $ENV{SCRIPT_NAME}, __LINE__);
612 my $r = $db->db_readwrite($dbh, qq~
613 SELECT next_invoice_at FROM `${DB}`.subscriptions WHERE id='$sid'
614 ~, $ENV{SCRIPT_NAME}, __LINE__);
615 $effective = $r ? $r->{next_invoice_at} : '';
616 }
617 $db->db_readwrite($dbh, qq~
618 UPDATE `${DB}`.subscriptions
619 SET pending_plan_id='$new_plan_id',
620 pending_cadence='$new_cadence',
621 pending_change_at='$effective',
622 cancel_at_period_end=0
623 WHERE id='$sid' AND user_id='$uid'
624 ~, $ENV{SCRIPT_NAME}, __LINE__);
625 return {
626 mode => 'deferred',
627 new_tier => $tier,
628 new_plan_id => $new_plan_id,
629 effective_at => $effective,
630 };
631}
632
633# Quote a real-money upgrade. Used by billing.cgi to render confirm-
634# modal copy ("you'll be charged $X.YZ today") and by billing_action.cgi
635# to know what to charge. Returns a hash with the full picture:
636#
637# {
638# classification => 'immediate' | 'deferred' | 'noop',
639# new_plan_price_cents => 2900, # MRR sticker price
640# proration_credit_cents => 1200, # value of unused current cycle
641# charge_today_cents => 1700, # max(price - proration, 0)
642# renewal_amount_cents => 2900,
643# renewal_interval => '1 MONTH' | '1 YEAR',
644# needs_payment_method => 1|0, # 1 if amount > 0 and no PM on file
645# has_payment_method => 1|0,
646# reason => 'noop'|'free_downgrade'|'paid_change'|...,
647# }
648#
649# For prorations we use a calendar-days approach: if the current cycle
650# has D days total and U of them are unused, credit = current_price * U/D.
651# Free -> paid: no proration (no prior price). Annual -> monthly: defers
652# anyway, no charge today.
653sub quote_plan_change {
654 my ($self, $db, $dbh, $DB, $uid, $new_plan_id, $new_cadence) = @_;
655 $uid =~ s/[^0-9]//g;
656 $new_plan_id =~ s/[^0-9]//g;
657 my %out = (
658 classification => 'noop',
659 new_plan_price_cents => 0,
660 proration_credit_cents => 0,
661 charge_today_cents => 0,
662 renewal_amount_cents => 0,
663 renewal_interval => '1 MONTH',
664 needs_payment_method => 0,
665 has_payment_method => 0,
666 reason => 'noop',
667 );
668 return \%out unless $uid && $new_plan_id;
669 return \%out unless $self->schema_ready($db, $dbh, $DB);
670
671 my $new_plan = $self->plan_by_id($db, $dbh, $DB, $new_plan_id);
672 return \%out unless $new_plan && $new_plan->{id};
673
674 my $cur_sub = $self->active_subscription($db, $dbh, $DB, $uid);
675 $new_cadence ||= ($cur_sub && $cur_sub->{cadence}) ? $cur_sub->{cadence} : 'monthly';
676 $new_cadence = 'monthly' unless $new_cadence eq 'annual';
677 $out{renewal_interval} = ($new_cadence eq 'annual') ? '1 YEAR' : '1 MONTH';
678
679 my $mode = $self->_classify_plan_change($cur_sub, $new_plan, $new_cadence);
680 $out{classification} = $mode;
681
682 my $new_price = $self->compute_charge_cents($new_plan, $new_cadence);
683 $out{new_plan_price_cents} = $new_price;
684 $out{renewal_amount_cents} = $new_price;
685
686 # Free target / noop: nothing to charge.
687 if ($mode eq 'noop' || $new_price <= 0) {
688 $out{reason} = ($mode eq 'noop') ? 'noop' : 'free_downgrade';
689 $out{charge_today_cents} = 0;
690 # Even for free-to-free changes, no PM required.
691 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $uid);
692 $out{has_payment_method} = ($cus && $pm) ? 1 : 0;
693 return \%out;
694 }
695
696 # Deferred (downgrade): no charge today.
697 if ($mode eq 'deferred') {
698 $out{reason} = 'deferred_downgrade';
699 $out{charge_today_cents} = 0;
700 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $uid);
701 $out{has_payment_method} = ($cus && $pm) ? 1 : 0;
702 return \%out;
703 }
704
705 # Immediate paid change. Compute proration credit if there's a
706 # current paid sub with an unused portion of its cycle remaining.
707 my $proration = 0;
708 if ($cur_sub && $cur_sub->{id} && $cur_sub->{price_cents} && $cur_sub->{next_invoice_at}) {
709 my $cur_price = $cur_sub->{price_cents} || 0;
710 if (($cur_sub->{cadence} || 'monthly') eq 'annual') {
711 $cur_price = $self->compute_charge_cents($cur_sub, 'annual');
712 }
713 # Days remaining in current cycle / days in current cycle.
714 # We rely on MySQL's date math so DST / month-length quirks
715 # don't bite us.
716 my $r = $db->db_readwrite($dbh, qq~
717 SELECT GREATEST(DATEDIFF('$cur_sub->{next_invoice_at}', NOW()), 0) AS days_left,
718 GREATEST(DATEDIFF(
719 '$cur_sub->{next_invoice_at}',
720 DATE_SUB('$cur_sub->{next_invoice_at}',
721 INTERVAL @{[ ($cur_sub->{cadence}||'monthly') eq 'annual' ? '1 YEAR' : '1 MONTH' ]})
722 ), 1) AS days_total
723 ~, $ENV{SCRIPT_NAME}, __LINE__);
724 my $days_left = ($r && $r->{days_left}) ? $r->{days_left} : 0;
725 my $days_total = ($r && $r->{days_total}) ? $r->{days_total} : 1;
726 $days_total = 1 if $days_total < 1;
727 $proration = int($cur_price * $days_left / $days_total);
728 $proration = 0 if $proration < 0;
729 $proration = $cur_price if $proration > $cur_price;
730 }
731 $out{proration_credit_cents} = $proration;
732 my $charge = $new_price - $proration;
733 $charge = 0 if $charge < 0;
734 $out{charge_today_cents} = $charge;
735 $out{reason} = 'paid_change';
736
737 # Payment-method check.
738 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $uid);
739 $out{has_payment_method} = ($cus && $pm) ? 1 : 0;
740 $out{needs_payment_method} = ($charge > 0 && !$out{has_payment_method}) ? 1 : 0;
741
742 return \%out;
743}
744
745# Execute an immediate paid plan change end-to-end. Charges Stripe FIRST,
746# then flips the plan only on success. Caller (billing_action.cgi) must
747# pass a configured MODS::ShopCart::Stripe instance.
748#
749# Returns:
750# { ok=>1, mode=>'charged', amount_cents=>1700, pi_id=>'pi_...',
751# new_tier=>'pro', new_plan_id=>5, invoice_id=>123 }
752# { ok=>0, reason=>'no_pm'|'card_declined'|'stripe_unconfigured'|'bad_plan',
753# error=>'human message (when card declined)' }
754#
755# For non-immediate or zero-cost changes the caller should keep using
756# change_plan() directly -- this helper assumes there's real money to
757# move.
758sub change_plan_with_charge {
759 my ($self, $db, $dbh, $DB, $uid, $new_plan_id, $new_cadence, $stripe) = @_;
760 $uid =~ s/[^0-9]//g;
761 $new_plan_id =~ s/[^0-9]//g;
762 return { ok => 0, reason => 'bad_input' } unless $uid && $new_plan_id;
763
764 my $quote = $self->quote_plan_change($db, $dbh, $DB, $uid, $new_plan_id, $new_cadence);
765 my $charge = $quote->{charge_today_cents} || 0;
766
767 # Caller mis-routed. Quote says no immediate charge -- defer to the
768 # regular flow so we don't try to charge $0.
769 if ($charge <= 0) {
770 my $r = $self->change_plan($db, $dbh, $DB, $uid, $new_plan_id, $new_cadence);
771 return {
772 ok => 1,
773 mode => $r->{mode},
774 new_tier => $r->{new_tier},
775 new_plan_id => $r->{new_plan_id},
776 amount_cents => 0,
777 effective_at => $r->{effective_at},
778 };
779 }
780
781 if ($quote->{needs_payment_method}) {
782 return { ok => 0, reason => 'no_pm' };
783 }
784 unless ($stripe && $stripe->is_configured) {
785 return { ok => 0, reason => 'stripe_unconfigured' };
786 }
787 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $uid);
788 return { ok => 0, reason => 'no_pm' } unless $cus && $pm;
789
790 my $new_plan = $self->plan_by_id($db, $dbh, $DB, $new_plan_id);
791 return { ok => 0, reason => 'bad_plan' } unless $new_plan && $new_plan->{id};
792
793 my $desc = "ShopCart - upgrade to " . ($new_plan->{display_name} || $new_plan->{tier} || 'paid plan');
794 # Idempotency: scope per (user, plan, second) so a stray double-
795 # submit can't double-charge. Two clicks in the same second collapse
796 # to a single Stripe call.
797 my $idem = sprintf('upgrade_%d_p%d_%d', $uid, $new_plan_id, time());
798
799 my $r = $stripe->create_subscription_charge(
800 amount_cents => $charge,
801 customer => $cus,
802 payment_method => $pm,
803 user_id => $uid,
804 idempotency_key => $idem,
805 description => $desc,
806 );
807
808 if ($r && $r->{error}) {
809 return { ok => 0, reason => 'card_declined', error => $r->{error} };
810 }
811 my $status = ($r && $r->{status}) ? $r->{status} : '';
812 unless ($status eq 'succeeded') {
813 return { ok => 0, reason => 'charge_failed', error => "Stripe returned status '$status'." };
814 }
815 my $pi_id = ($r && $r->{id}) ? $r->{id} : '';
816
817 # Charge cleared. Flip the plan now.
818 my $change = $self->change_plan($db, $dbh, $DB, $uid, $new_plan_id, $new_cadence);
819 unless ($change && ($change->{mode} || '') eq 'immediate') {
820 # Plan flip didn't happen as expected (shouldn't be possible
821 # given the quote came back paid_change). The card is already
822 # charged, so we record the cash as account credit rather than
823 # losing it -- the user will see it on their next invoice.
824 $self->grant_credit($db, $dbh, $DB,
825 user_id => $uid,
826 amount_cents => $charge,
827 reason => 'refund',
828 note => 'Upgrade charged but plan change failed -- balance credited back.',
829 );
830 return { ok => 0, reason => 'plan_flip_failed', error => 'Charge captured; credit applied to your account.' };
831 }
832
833 # Look up the new sub for the invoice link and the period.
834 my $new_sub = $self->active_subscription($db, $dbh, $DB, $uid);
835 my $new_sid = ($new_sub && $new_sub->{id}) ? $new_sub->{id} : 0;
836
837 # Record a paid invoice for today's upgrade so it shows up in
838 # invoice history + admin billing. period_end = day before the
839 # next renewal so periods don't overlap.
840 my $base_num = sprintf('INV-%07d-UPG-%d', $uid, time());
841 $db->db_readwrite($dbh, qq~
842 INSERT INTO `${DB}`.invoices
843 SET user_id='$uid',
844 subscription_id='$new_sid',
845 invoice_number='$base_num',
846 period_start=CURDATE(),
847 period_end=DATE_SUB(DATE('@{[ $new_sub->{next_invoice_at} || '9999-12-31' ]}'), INTERVAL 1 DAY),
848 amount_due_cents='$charge',
849 credit_applied_cents=0,
850 cash_paid_cents='$charge',
851 currency='USD',
852 status='paid',
853 issued_at=NOW(),
854 paid_at=NOW(),
855 created_at=NOW(),
856 stripe_payment_intent_id='$pi_id'
857 ~, $ENV{SCRIPT_NAME}, __LINE__);
858 my $inv = $db->db_readwrite($dbh, qq~
859 SELECT id FROM `${DB}`.invoices WHERE invoice_number='$base_num' LIMIT 1
860 ~, $ENV{SCRIPT_NAME}, __LINE__);
861
862 return {
863 ok => 1,
864 mode => 'charged',
865 amount_cents => $charge,
866 pi_id => $pi_id,
867 new_tier => $change->{new_tier},
868 new_plan_id => $change->{new_plan_id},
869 invoice_id => ($inv && $inv->{id}) ? $inv->{id} : 0,
870 };
871}
872
873# Fallback path used only when pending columns are missing -- applies
874# the change immediately rather than dropping the request. Marked
875# _fallback so the caller can tell the user we couldn't defer.
876sub _apply_immediate_change {
877 my ($self, $db, $dbh, $DB, $uid, $cur_sub, $new_plan_id, $new_cadence, $tier, %opt) = @_;
878 my $interval = ($new_cadence eq 'annual') ? '1 YEAR' : '1 MONTH';
879 if ($cur_sub && $cur_sub->{id}) {
880 my $sid = $cur_sub->{id};
881 $db->db_readwrite($dbh, qq~
882 UPDATE `${DB}`.subscriptions
883 SET plan_id='$new_plan_id',
884 cadence='$new_cadence',
885 status='active',
886 cancel_at_period_end=0,
887 next_invoice_at=DATE_ADD(NOW(), INTERVAL $interval)
888 WHERE id='$sid' AND user_id='$uid'
889 ~, $ENV{SCRIPT_NAME}, __LINE__);
890 }
891 $db->db_readwrite($dbh, qq~
892 UPDATE `${DB}`.users SET plan_tier='$tier' WHERE id='$uid'
893 ~, $ENV{SCRIPT_NAME}, __LINE__);
894 return {
895 mode => 'immediate',
896 new_tier => $tier,
897 new_plan_id => $new_plan_id,
898 fallback => $opt{_fallback} ? 1 : 0,
899 };
900}
901
902# Flip deferred plan changes whose pending_change_at has passed. Cheap
903# enough to call at the top of billing.cgi (and the eventual billing
904# worker). No-op when the columns aren't migrated yet or no rows are
905# due.
906sub apply_pending_changes_if_due {
907 my ($self, $db, $dbh, $DB, $uid) = @_;
908 $uid =~ s/[^0-9]//g;
909 return 0 unless $uid;
910 return 0 unless $self->schema_ready($db, $dbh, $DB);
911 return 0 unless $self->_pending_cols_ready($db, $dbh, $DB);
912
913 my @rows = $db->db_readwrite_multiple($dbh, qq~
914 SELECT s.id, s.user_id, s.pending_plan_id, s.pending_cadence, s.cadence,
915 p.tier
916 FROM `${DB}`.subscriptions s
917 JOIN `${DB}`.billing_plans p ON p.id = s.pending_plan_id
918 WHERE s.user_id='$uid'
919 AND s.pending_plan_id IS NOT NULL
920 AND s.pending_change_at IS NOT NULL
921 AND s.pending_change_at <= NOW()
922 ~, $ENV{SCRIPT_NAME}, __LINE__);
923
924 my $applied = 0;
925 foreach my $r (@rows) {
926 my $sid = $r->{id};
927 my $new_cad = $r->{pending_cadence} || $r->{cadence} || 'monthly';
928 $new_cad = 'monthly' unless $new_cad eq 'annual';
929 my $interval = ($new_cad eq 'annual') ? '1 YEAR' : '1 MONTH';
930 my $new_plan = $r->{pending_plan_id};
931 my $tier = $r->{tier} || 'free';
932 $db->db_readwrite($dbh, qq~
933 UPDATE `${DB}`.subscriptions
934 SET plan_id='$new_plan',
935 cadence='$new_cad',
936 pending_plan_id=NULL,
937 pending_cadence=NULL,
938 pending_change_at=NULL,
939 next_invoice_at=DATE_ADD(NOW(), INTERVAL $interval)
940 WHERE id='$sid'
941 ~, $ENV{SCRIPT_NAME}, __LINE__);
942 $db->db_readwrite($dbh, qq~
943 UPDATE `${DB}`.users SET plan_tier='$tier' WHERE id='$uid'
944 ~, $ENV{SCRIPT_NAME}, __LINE__);
945 $applied++;
946 }
947
948 # Trial-end promotion: any 'trialing' subscription whose trial_end
949 # has passed should flip to 'active'. The billing worker invokes
950 # this with $uid for due users; we also run it on every billing.cgi
951 # load so an inactive seller's trial still ends on schedule (the
952 # next invoice will be due either now or shortly, picked up on the
953 # next worker tick).
954 $applied += $self->_promote_expired_trials($db, $dbh, $DB, $uid);
955
956 return $applied;
957}
958
959# Promote trialing -> active where trial_end <= NOW(). Pulls the
960# plan's tier in the same query so users.plan_tier stays in lockstep.
961# Caller can pass a specific user_id; passing 0 means "every user".
962sub _promote_expired_trials {
963 my ($self, $db, $dbh, $DB, $uid) = @_;
964 $uid = 0 unless $uid;
965 $uid =~ s/[^0-9]//g;
966 my $where_uid = $uid ? "AND s.user_id='$uid'" : '';
967
968 my @rows = $db->db_readwrite_multiple($dbh, qq~
969 SELECT s.id, s.user_id, p.tier
970 FROM `${DB}`.subscriptions s
971 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
972 WHERE s.status='trialing'
973 AND s.trial_end IS NOT NULL
974 AND s.trial_end <= NOW()
975 $where_uid
976 ~, $ENV{SCRIPT_NAME}, __LINE__);
977
978 my $n = 0;
979 foreach my $r (@rows) {
980 my $sid = $r->{id};
981 my $u = $r->{user_id};
982 my $tier = $r->{tier} || 'free';
983 # trial_end becomes the anchor for the first paid cycle --
984 # next_invoice_at sits at trial_end already (set by change_plan)
985 # so the very next worker pass will issue the first invoice.
986 $db->db_readwrite($dbh, qq~
987 UPDATE `${DB}`.subscriptions
988 SET status='active'
989 WHERE id='$sid' AND status='trialing'
990 ~, $ENV{SCRIPT_NAME}, __LINE__);
991 $db->db_readwrite($dbh, qq~
992 UPDATE `${DB}`.users SET plan_tier='$tier' WHERE id='$u'
993 ~, $ENV{SCRIPT_NAME}, __LINE__);
994 $n++;
995 }
996 return $n;
997}
998
999# ---- Recurring-charge worker support --------------------------------
1000# These methods power _billing_worker.pl. The contract:
1001# 1. next_due_subscriptions -> list rows to process
1002# 2. for each row:
1003# generate_invoice -> idempotent create
1004# apply_credit_to_invoice -> consume credit, idempotent
1005# charge_invoice -> call Stripe + advance state
1006# Every method is safe to re-run on the same row -- the worker may
1007# crash mid-pass and the next cron tick must NOT double-charge.
1008
1009sub next_due_subscriptions {
1010 my ($self, $db, $dbh, $DB, $limit) = @_;
1011 $limit ||= 50;
1012 $limit =~ s/[^0-9]//g;
1013 $limit = 50 unless $limit;
1014 return () unless $self->schema_ready($db, $dbh, $DB);
1015
1016 # Past-due rows get retried each tick until the worker's retry
1017 # ceiling kicks them to 'paused'. We include 'past_due' so the
1018 # billing worker is the single owner of dunning state.
1019 return $db->db_readwrite_multiple($dbh, qq~
1020 SELECT s.id AS subscription_id,
1021 s.user_id, s.plan_id, s.cadence, s.status,
1022 s.started_at, s.next_invoice_at,
1023 s.last_charge_failed_at,
1024 p.tier, p.display_name, p.price_cents, p.currency,
1025 p.yearly_mode, p.yearly_pct_off, p.yearly_off_cents, p.yearly_price_cents,
1026 u.email, u.display_name AS user_display_name,
1027 u.stripe_customer_id
1028 FROM `${DB}`.subscriptions s
1029 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1030 JOIN `${DB}`.users u ON u.id = s.user_id
1031 WHERE s.status IN ('active','past_due')
1032 AND s.next_invoice_at IS NOT NULL
1033 AND s.next_invoice_at <= NOW()
1034 AND p.tier <> 'free'
1035 ORDER BY s.next_invoice_at ASC
1036 LIMIT $limit
1037 ~, $ENV{SCRIPT_NAME}, __LINE__);
1038}
1039
1040# Compute the cash amount due for a given plan + cadence. Annual rows
1041# use the configured yearly_mode (price / pct_off / off_cents) to
1042# derive the annual total; monthly is just the base price.
1043sub compute_charge_cents {
1044 my ($self, $plan, $cadence) = @_;
1045 return 0 unless $plan;
1046 my $price = $plan->{price_cents} || 0;
1047 return $price if (($cadence || 'monthly') ne 'annual');
1048 my $mode = $plan->{yearly_mode} || 'price';
1049 if ($mode eq 'price' && $plan->{yearly_price_cents}) {
1050 return $plan->{yearly_price_cents};
1051 }
1052 my $full_year = $price * 12;
1053 if ($mode eq 'pct_off' && $plan->{yearly_pct_off}) {
1054 my $off = int($full_year * ($plan->{yearly_pct_off} / 100));
1055 return $full_year - $off;
1056 }
1057 if ($mode eq 'off_cents' && $plan->{yearly_off_cents}) {
1058 return $full_year - $plan->{yearly_off_cents};
1059 }
1060 return $full_year;
1061}
1062
1063# Idempotent invoice generation. Looks for an existing non-void invoice
1064# for (user, subscription, period_start). If found, returns its id and
1065# DOES NOT create a new row. The period_start is set to next_invoice_at
1066# at the moment of the call -- that's what the worker uses to claim a
1067# given billing cycle.
1068sub generate_invoice {
1069 my ($self, $db, $dbh, $DB, $sub) = @_;
1070 return 0 unless $self->schema_ready($db, $dbh, $DB);
1071 return 0 unless $sub && $sub->{subscription_id} && $sub->{user_id};
1072
1073 my $sid = $sub->{subscription_id}; $sid =~ s/[^0-9]//g;
1074 my $uid = $sub->{user_id}; $uid =~ s/[^0-9]//g;
1075 my $plan_id = $sub->{plan_id}; $plan_id =~ s/[^0-9]//g;
1076 return 0 unless $sid && $uid;
1077
1078 my $cadence = ($sub->{cadence} || 'monthly') eq 'annual' ? 'annual' : 'monthly';
1079 my $interval = ($cadence eq 'annual') ? '1 YEAR' : '1 MONTH';
1080
1081 # period_start = the next_invoice_at anchor (we're invoicing FOR
1082 # the cycle that ends at next_invoice_at + 1 interval).
1083 # period_end = period_start + 1 interval - 1 day.
1084 my $anchor = $sub->{next_invoice_at};
1085 return 0 unless $anchor;
1086
1087 # Reuse-if-exists check.
1088 my $existing = $db->db_readwrite($dbh, qq~
1089 SELECT id FROM `${DB}`.invoices
1090 WHERE user_id='$uid'
1091 AND subscription_id='$sid'
1092 AND period_start=DATE('$anchor')
1093 AND status <> 'void'
1094 LIMIT 1
1095 ~, $ENV{SCRIPT_NAME}, __LINE__);
1096 return $existing->{id} if ($existing && $existing->{id});
1097
1098 # Number: INV-{seven-digit user id}-{YYYYMM}. If a stray void row
1099 # of the same number exists from a prior cycle we fall back to a
1100 # suffix; the unique key ensures we don't ever collide silently.
1101 my ($yyyy, $mm) = ($anchor =~ /^(\d{4})-(\d{2})/);
1102 $yyyy ||= 1970; $mm ||= '01';
1103 my $base = sprintf('INV-%07d-%s%s', $uid, $yyyy, $mm);
1104 my $num = $base;
1105 my $i = 1;
1106 while (1) {
1107 my $clash = $db->db_readwrite($dbh, qq~
1108 SELECT id FROM `${DB}`.invoices WHERE invoice_number='$num' LIMIT 1
1109 ~, $ENV{SCRIPT_NAME}, __LINE__);
1110 last unless ($clash && $clash->{id});
1111 $i++;
1112 $num = $base . sprintf('-%d', $i);
1113 last if $i > 99; # bail-out -- should never hit in practice
1114 }
1115
1116 my $amount = $self->compute_charge_cents($sub, $cadence);
1117 return 0 unless $amount > 0;
1118
1119 $db->db_readwrite($dbh, qq~
1120 INSERT INTO `${DB}`.invoices
1121 SET user_id='$uid',
1122 subscription_id='$sid',
1123 invoice_number='$num',
1124 period_start=DATE('$anchor'),
1125 period_end=DATE_SUB(DATE_ADD(DATE('$anchor'), INTERVAL $interval), INTERVAL 1 DAY),
1126 amount_due_cents='$amount',
1127 credit_applied_cents=0,
1128 cash_paid_cents=0,
1129 currency='USD',
1130 status='open',
1131 issued_at=NOW(),
1132 created_at=NOW()
1133 ~, $ENV{SCRIPT_NAME}, __LINE__);
1134
1135 my $r = $db->db_readwrite($dbh, qq~
1136 SELECT id FROM `${DB}`.invoices WHERE invoice_number='$num' LIMIT 1
1137 ~, $ENV{SCRIPT_NAME}, __LINE__);
1138 return ($r && $r->{id}) ? $r->{id} : 0;
1139}
1140
1141# Idempotent credit application. If credit_applied_cents is already > 0
1142# we treat it as already applied and skip. Otherwise: read balance,
1143# clamp to amount_due, write the -ledger row, update the invoice.
1144sub apply_credit_to_invoice {
1145 my ($self, $db, $dbh, $DB, $invoice_id) = @_;
1146 return 0 unless $self->schema_ready($db, $dbh, $DB);
1147 $invoice_id =~ s/[^0-9]//g;
1148 return 0 unless $invoice_id;
1149
1150 my $inv = $db->db_readwrite($dbh, qq~
1151 SELECT id, user_id, amount_due_cents, credit_applied_cents, status
1152 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1153 ~, $ENV{SCRIPT_NAME}, __LINE__);
1154 return 0 unless ($inv && $inv->{id});
1155 return $inv->{credit_applied_cents} if $inv->{credit_applied_cents} > 0;
1156 return 0 if $inv->{status} eq 'paid' || $inv->{status} eq 'void';
1157
1158 my $uid = $inv->{user_id};
1159 my $amount = $inv->{amount_due_cents} || 0;
1160 my $bal = $self->credit_balance_cents($db, $dbh, $DB, $uid);
1161 return 0 if $bal <= 0;
1162
1163 my $apply = ($bal < $amount) ? $bal : $amount;
1164 return 0 unless $apply > 0;
1165
1166 my $neg = 0 - $apply;
1167 my $note = 'Applied to invoice #' . $invoice_id;
1168 $note =~ s/'/''/g;
1169
1170 $db->db_readwrite($dbh, qq~
1171 INSERT INTO `${DB}`.credit_ledger
1172 SET user_id='$uid',
1173 amount_cents='$neg',
1174 reason='applied_to_invoice',
1175 related_invoice_id='$invoice_id',
1176 note='$note',
1177 created_at=NOW()
1178 ~, $ENV{SCRIPT_NAME}, __LINE__);
1179
1180 $db->db_readwrite($dbh, qq~
1181 UPDATE `${DB}`.invoices
1182 SET credit_applied_cents='$apply'
1183 WHERE id='$invoice_id'
1184 ~, $ENV{SCRIPT_NAME}, __LINE__);
1185
1186 return $apply;
1187}
1188
1189# Get the user's default Stripe payment_method id. Returns (cus_id,
1190# pm_id) -- both required by Stripe::create_subscription_charge.
1191sub default_payment_method_for_user {
1192 my ($self, $db, $dbh, $DB, $uid) = @_;
1193 $uid =~ s/[^0-9]//g;
1194 return (undef, undef) unless $uid;
1195 return (undef, undef) unless $self->schema_ready($db, $dbh, $DB);
1196 my $r = $db->db_readwrite($dbh, qq~
1197 SELECT stripe_customer_id, stripe_payment_method_id
1198 FROM `${DB}`.payment_methods
1199 WHERE user_id='$uid'
1200 ORDER BY is_default DESC, id DESC
1201 LIMIT 1
1202 ~, $ENV{SCRIPT_NAME}, __LINE__);
1203 return (undef, undef) unless $r;
1204 return ($r->{stripe_customer_id}, $r->{stripe_payment_method_id});
1205}
1206
1207# Update an invoice to paid + advance the subscription's next_invoice_at.
1208# Called by the worker on Stripe 'succeeded' AND by the webhook on
1209# payment_intent.succeeded -- whichever fires first wins; the other
1210# is a no-op via the status='paid' early-return.
1211sub mark_invoice_paid {
1212 my ($self, $db, $dbh, $DB, $invoice_id, %p) = @_;
1213 return 0 unless $self->schema_ready($db, $dbh, $DB);
1214 $invoice_id =~ s/[^0-9]//g;
1215 return 0 unless $invoice_id;
1216
1217 my $inv = $db->db_readwrite($dbh, qq~
1218 SELECT id, user_id, subscription_id, amount_due_cents,
1219 credit_applied_cents, status
1220 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1221 ~, $ENV{SCRIPT_NAME}, __LINE__);
1222 return 0 unless ($inv && $inv->{id});
1223 return 1 if $inv->{status} eq 'paid'; # idempotent no-op
1224
1225 my $cash = defined $p{cash_paid_cents} ? $p{cash_paid_cents}
1226 : ($inv->{amount_due_cents} - ($inv->{credit_applied_cents} || 0));
1227 $cash = 0 if $cash < 0;
1228 $cash =~ s/[^0-9]//g;
1229
1230 my $pi = defined $p{stripe_payment_intent_id} ? $p{stripe_payment_intent_id} : '';
1231 $pi =~ s/[^A-Za-z0-9_]//g;
1232 my $pi_sql = length($pi) ? "stripe_payment_intent_id='$pi'," : '';
1233
1234 $db->db_readwrite($dbh, qq~
1235 UPDATE `${DB}`.invoices
1236 SET status='paid',
1237 cash_paid_cents='$cash',
1238 $pi_sql
1239 paid_at=NOW(),
1240 failure_reason=NULL
1241 WHERE id='$invoice_id'
1242 ~, $ENV{SCRIPT_NAME}, __LINE__);
1243
1244 # Advance the sub: next_invoice_at += cadence, clear past_due
1245 # error, status='active'. We use a fresh read so we don't trust
1246 # a stale cadence cached on the worker.
1247 if ($inv->{subscription_id}) {
1248 my $sid = $inv->{subscription_id}; $sid =~ s/[^0-9]//g;
1249 my $s = $db->db_readwrite($dbh, qq~
1250 SELECT cadence FROM `${DB}`.subscriptions WHERE id='$sid' LIMIT 1
1251 ~, $ENV{SCRIPT_NAME}, __LINE__);
1252 my $cad = ($s && $s->{cadence} && $s->{cadence} eq 'annual') ? '1 YEAR' : '1 MONTH';
1253 $db->db_readwrite($dbh, qq~
1254 UPDATE `${DB}`.subscriptions
1255 SET status='active',
1256 last_charge_failed_at=NULL,
1257 last_charge_error=NULL,
1258 next_invoice_at=DATE_ADD(next_invoice_at, INTERVAL $cad)
1259 WHERE id='$sid'
1260 ~, $ENV{SCRIPT_NAME}, __LINE__);
1261 }
1262 return 1;
1263}
1264
1265sub mark_invoice_failed {
1266 my ($self, $db, $dbh, $DB, $invoice_id, %p) = @_;
1267 return 0 unless $self->schema_ready($db, $dbh, $DB);
1268 $invoice_id =~ s/[^0-9]//g;
1269 return 0 unless $invoice_id;
1270
1271 my $reason = defined $p{reason} ? $p{reason} : '';
1272 $reason =~ s/'/''/g;
1273 $reason = substr($reason, 0, 480);
1274 my $pi = defined $p{stripe_payment_intent_id} ? $p{stripe_payment_intent_id} : '';
1275 $pi =~ s/[^A-Za-z0-9_]//g;
1276 my $pi_sql = length($pi) ? "stripe_payment_intent_id='$pi'," : '';
1277
1278 $db->db_readwrite($dbh, qq~
1279 UPDATE `${DB}`.invoices
1280 SET status='failed',
1281 $pi_sql
1282 failure_reason='$reason'
1283 WHERE id='$invoice_id'
1284 ~, $ENV{SCRIPT_NAME}, __LINE__);
1285
1286 my $inv = $db->db_readwrite($dbh, qq~
1287 SELECT subscription_id FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1288 ~, $ENV{SCRIPT_NAME}, __LINE__);
1289 if ($inv && $inv->{subscription_id}) {
1290 my $sid = $inv->{subscription_id}; $sid =~ s/[^0-9]//g;
1291 $db->db_readwrite($dbh, qq~
1292 UPDATE `${DB}`.subscriptions
1293 SET status='past_due',
1294 last_charge_failed_at=NOW(),
1295 last_charge_error='$reason'
1296 WHERE id='$sid'
1297 ~, $ENV{SCRIPT_NAME}, __LINE__);
1298 }
1299 return 1;
1300}
1301
1302# Orchestrates one invoice through to a terminal status. Returns a
1303# hash describing the outcome:
1304# { mode => 'paid_by_credit' | 'paid_by_card' | 'failed' | 'noop',
1305# reason => '...', payment_intent_id => '...' }
1306# Safe to call multiple times for the same invoice.
1307sub charge_invoice {
1308 my ($self, $db, $dbh, $DB, $invoice_id, $stripe) = @_;
1309 return { mode => 'noop', reason => 'schema' } unless $self->schema_ready($db, $dbh, $DB);
1310 $invoice_id =~ s/[^0-9]//g;
1311 return { mode => 'noop', reason => 'bad_id' } unless $invoice_id;
1312
1313 my $inv = $db->db_readwrite($dbh, qq~
1314 SELECT id, user_id, subscription_id, amount_due_cents,
1315 credit_applied_cents, status, stripe_payment_intent_id
1316 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1317 ~, $ENV{SCRIPT_NAME}, __LINE__);
1318 return { mode => 'noop', reason => 'not_found' } unless ($inv && $inv->{id});
1319 return { mode => 'noop', reason => 'already_paid' } if $inv->{status} eq 'paid';
1320 return { mode => 'noop', reason => 'void' } if $inv->{status} eq 'void';
1321
1322 my $amount = $inv->{amount_due_cents} || 0;
1323 my $credit = $inv->{credit_applied_cents} || 0;
1324 my $cash = $amount - $credit;
1325 $cash = 0 if $cash < 0;
1326
1327 # Fully covered by credit: paid immediately, no Stripe call.
1328 if ($cash == 0) {
1329 $self->mark_invoice_paid($db, $dbh, $DB, $invoice_id,
1330 cash_paid_cents => 0);
1331 return { mode => 'paid_by_credit' };
1332 }
1333
1334 # Stripe not configured -> mark past_due with a clear reason so
1335 # the admin sees it on /admin_billing.cgi.
1336 unless ($stripe && $stripe->is_configured) {
1337 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1338 reason => 'Stripe is not configured. Add keys in Software Configuration to enable charges.');
1339 return { mode => 'failed', reason => 'stripe_unconfigured' };
1340 }
1341
1342 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $inv->{user_id});
1343 unless ($cus && $pm) {
1344 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1345 reason => 'No payment method on file. Add a card on the Billing page.');
1346 return { mode => 'failed', reason => 'no_pm' };
1347 }
1348
1349 my $r = $stripe->create_subscription_charge(
1350 amount_cents => $cash,
1351 customer => $cus,
1352 payment_method => $pm,
1353 invoice_id => $invoice_id,
1354 user_id => $inv->{user_id},
1355 subscription_id => ($inv->{subscription_id} || ''),
1356 idempotency_key => "sub_invoice_$invoice_id",
1357 description => "ShopCart subscription invoice #$invoice_id",
1358 );
1359
1360 if ($r && $r->{error}) {
1361 # Stripe-side reject (card declined, 3DS required off-session,
1362 # etc.) -- the API surfaces the human reason via error.message.
1363 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1364 reason => $r->{error},
1365 stripe_payment_intent_id => ($r->{_raw} && $r->{_raw}{error} && $r->{_raw}{error}{payment_intent} && $r->{_raw}{error}{payment_intent}{id}) ? $r->{_raw}{error}{payment_intent}{id} : '',
1366 );
1367 return { mode => 'failed', reason => $r->{error} };
1368 }
1369
1370 my $status = $r->{status} || '';
1371 my $pi_id = $r->{id} || '';
1372
1373 if ($status eq 'succeeded') {
1374 $self->mark_invoice_paid($db, $dbh, $DB, $invoice_id,
1375 cash_paid_cents => $cash,
1376 stripe_payment_intent_id => $pi_id);
1377 return { mode => 'paid_by_card', payment_intent_id => $pi_id };
1378 }
1379
1380 # Anything else (requires_action / requires_payment_method /
1381 # processing) is treated as a failure on the off-session path.
1382 # The webhook will mark it paid later if 'processing' eventually
1383 # succeeds.
1384 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1385 reason => "Stripe returned status '$status' (off-session charge could not complete).",
1386 stripe_payment_intent_id => $pi_id);
1387 return { mode => 'failed', reason => $status, payment_intent_id => $pi_id };
1388}
1389
1390# Cancel a previously-scheduled deferred plan change. The seller
1391# clicked "Keep my current plan" while the downgrade was queued.
1392sub clear_pending_change {
1393 my ($self, $db, $dbh, $DB, $uid) = @_;
1394 $uid =~ s/[^0-9]//g;
1395 return 0 unless $uid;
1396 return 0 unless $self->schema_ready($db, $dbh, $DB);
1397 return 0 unless $self->_pending_cols_ready($db, $dbh, $DB);
1398 $db->db_readwrite($dbh, qq~
1399 UPDATE `${DB}`.subscriptions
1400 SET pending_plan_id=NULL,
1401 pending_cadence=NULL,
1402 pending_change_at=NULL
1403 WHERE user_id='$uid'
1404 AND pending_plan_id IS NOT NULL
1405 ~, $ENV{SCRIPT_NAME}, __LINE__);
1406 return 1;
1407}
1408
1409# ---- Credit ledger ---------------------------------------------------
1410# Balance = simple SUM over the append-only ledger. Always recomputed
1411# from the source of truth rather than cached.
1412sub credit_balance_cents {
1413 my ($self, $db, $dbh, $DB, $uid) = @_;
1414 $uid =~ s/[^0-9]//g;
1415 return 0 unless $uid;
1416 return 0 unless $self->schema_ready($db, $dbh, $DB);
1417
1418 my $r = $db->db_readwrite($dbh, qq~
1419 SELECT COALESCE(SUM(amount_cents),0) AS n
1420 FROM `${DB}`.credit_ledger
1421 WHERE user_id='$uid'
1422 ~, $ENV{SCRIPT_NAME}, __LINE__);
1423 return ($r && defined $r->{n}) ? $r->{n} : 0;
1424}
1425
1426sub credit_history {
1427 my ($self, $db, $dbh, $DB, $uid, $limit) = @_;
1428 $uid =~ s/[^0-9]//g;
1429 return () unless $uid;
1430 return () unless $self->schema_ready($db, $dbh, $DB);
1431
1432 $limit ||= 25;
1433 $limit =~ s/[^0-9]//g;
1434 $limit = 25 unless $limit;
1435 $limit = 200 if $limit > 200;
1436
1437 return $db->db_readwrite_multiple($dbh, qq~
1438 SELECT id, amount_cents, reason, related_invoice_id,
1439 granted_by_user_id, note, created_at
1440 FROM `${DB}`.credit_ledger
1441 WHERE user_id='$uid'
1442 ORDER BY created_at DESC, id DESC
1443 LIMIT $limit
1444 ~, $ENV{SCRIPT_NAME}, __LINE__);
1445}
1446
1447# Grant credit. Used by:
1448# - admin refund-as-credit action (reason='refund')
1449# - admin manual grant (reason='manual_grant')
1450# - promotional bonus (reason='promotional')
1451# Returns the new credit_ledger row id (or 0 on failure).
1452sub grant_credit {
1453 my ($self, $db, $dbh, $DB, %a) = @_;
1454 return 0 unless $self->schema_ready($db, $dbh, $DB);
1455
1456 my $uid = $a{user_id}; $uid =~ s/[^0-9]//g;
1457 my $amount = $a{amount_cents}; $amount =~ s/[^0-9-]//g;
1458 my $reason = $a{reason} || 'manual_grant';
1459 my $admin = defined $a{granted_by_user_id} ? $a{granted_by_user_id} : '';
1460 $admin =~ s/[^0-9]//g;
1461 my $rel = defined $a{related_invoice_id} ? $a{related_invoice_id} : '';
1462 $rel =~ s/[^0-9]//g;
1463 my $note = defined $a{note} ? $a{note} : '';
1464 $note =~ s/'/''/g;
1465 $note = substr($note, 0, 480);
1466
1467 return 0 unless $uid && $amount;
1468 my %ok = map { $_ => 1 } qw(refund manual_grant promotional reversal);
1469 return 0 unless $ok{$reason};
1470
1471 my $admin_sql = $admin eq '' ? 'NULL' : "'$admin'";
1472 my $rel_sql = $rel eq '' ? 'NULL' : "'$rel'";
1473
1474 my $r = $db->db_readwrite($dbh, qq~
1475 INSERT INTO `${DB}`.credit_ledger
1476 SET user_id='$uid',
1477 amount_cents='$amount',
1478 reason='$reason',
1479 related_invoice_id=$rel_sql,
1480 granted_by_user_id=$admin_sql,
1481 note='$note'
1482 ~, $ENV{SCRIPT_NAME}, __LINE__);
1483 return ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0;
1484}
1485
1486# ---- Invoice listing -------------------------------------------------
1487sub list_invoices {
1488 my ($self, $db, $dbh, $DB, $uid, $limit) = @_;
1489 $uid =~ s/[^0-9]//g;
1490 return () unless $uid;
1491 return () unless $self->schema_ready($db, $dbh, $DB);
1492
1493 $limit ||= 24;
1494 $limit =~ s/[^0-9]//g;
1495 $limit = 24 unless $limit;
1496 $limit = 200 if $limit > 200;
1497
1498 return $db->db_readwrite_multiple($dbh, qq~
1499 SELECT id, invoice_number, period_start, period_end,
1500 amount_due_cents, credit_applied_cents, cash_paid_cents,
1501 currency, status, failure_reason,
1502 issued_at, paid_at, created_at
1503 FROM `${DB}`.invoices
1504 WHERE user_id='$uid'
1505 ORDER BY COALESCE(issued_at, created_at) DESC, id DESC
1506 LIMIT $limit
1507 ~, $ENV{SCRIPT_NAME}, __LINE__);
1508}
1509
1510# Single invoice (for the receipt drilldown).
1511sub get_invoice {
1512 my ($self, $db, $dbh, $DB, $invoice_id, $uid_for_ownership) = @_;
1513 $invoice_id =~ s/[^0-9]//g;
1514 return {} unless $invoice_id;
1515 return {} unless $self->schema_ready($db, $dbh, $DB);
1516
1517 my $owner_sql = '';
1518 if (defined $uid_for_ownership) {
1519 my $u = $uid_for_ownership; $u =~ s/[^0-9]//g;
1520 $owner_sql = " AND user_id='$u'" if $u;
1521 }
1522
1523 my $r = $db->db_readwrite($dbh, qq~
1524 SELECT id, user_id, subscription_id, invoice_number,
1525 period_start, period_end,
1526 amount_due_cents, credit_applied_cents, cash_paid_cents,
1527 currency, status, failure_reason,
1528 issued_at, paid_at, created_at
1529 FROM `${DB}`.invoices
1530 WHERE id='$invoice_id' $owner_sql
1531 LIMIT 1
1532 ~, $ENV{SCRIPT_NAME}, __LINE__);
1533 return ($r && $r->{id}) ? $r : {};
1534}
1535
1536sub list_invoice_items {
1537 my ($self, $db, $dbh, $DB, $invoice_id) = @_;
1538 $invoice_id =~ s/[^0-9]//g;
1539 return () unless $invoice_id;
1540 return () unless $self->schema_ready($db, $dbh, $DB);
1541
1542 return $db->db_readwrite_multiple($dbh, qq~
1543 SELECT id, kind, description, amount_cents, quantity
1544 FROM `${DB}`.invoice_items
1545 WHERE invoice_id='$invoice_id'
1546 ORDER BY id ASC
1547 ~, $ENV{SCRIPT_NAME}, __LINE__);
1548}
1549
1550# ---- Payment methods -------------------------------------------------
1551sub list_payment_methods {
1552 my ($self, $db, $dbh, $DB, $uid) = @_;
1553 $uid =~ s/[^0-9]//g;
1554 return () unless $uid;
1555 return () unless $self->schema_ready($db, $dbh, $DB);
1556
1557 return $db->db_readwrite_multiple($dbh, qq~
1558 SELECT id, brand, last4, exp_month, exp_year, is_default,
1559 stripe_payment_method_id, stripe_customer_id, created_at
1560 FROM `${DB}`.payment_methods
1561 WHERE user_id='$uid'
1562 ORDER BY is_default DESC, id DESC
1563 ~, $ENV{SCRIPT_NAME}, __LINE__);
1564}
1565
1566# Single PM row scoped by (user_id, id). Used by the delete and
1567# set-default actions before we let a request touch the row -- enforces
1568# the seller can only see their own cards.
1569sub payment_method_by_id {
1570 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1571 $uid =~ s/[^0-9]//g;
1572 $pm_id =~ s/[^0-9]//g;
1573 return undef unless $uid && $pm_id;
1574 return undef unless $self->schema_ready($db, $dbh, $DB);
1575 my $r = $db->db_readwrite($dbh, qq~
1576 SELECT id, user_id, brand, last4, exp_month, exp_year,
1577 is_default, stripe_payment_method_id, stripe_customer_id
1578 FROM `${DB}`.payment_methods
1579 WHERE id='$pm_id' AND user_id='$uid'
1580 LIMIT 1
1581 ~, $ENV{SCRIPT_NAME}, __LINE__);
1582 return ($r && $r->{id}) ? $r : undef;
1583}
1584
1585# Insert a new payment_methods row after Stripe Elements + SetupIntent
1586# have produced a confirmed payment_method id. Caller has already done
1587# the Stripe API retrieve to pull brand/last4/exp -- we never touch the
1588# PAN here. First card auto-promotes to default; subsequent cards can
1589# be promoted explicitly via set_default_payment_method().
1590sub save_payment_method {
1591 my ($self, $db, $dbh, $DB, $uid, %a) = @_;
1592 $uid =~ s/[^0-9]//g;
1593 return 0 unless $uid;
1594 return 0 unless $self->schema_ready($db, $dbh, $DB);
1595
1596 my $brand = defined $a{brand} ? $a{brand} : '';
1597 $brand =~ s/[^a-zA-Z_\-]//g;
1598 $brand = substr($brand, 0, 40);
1599 my $last4 = defined $a{last4} ? $a{last4} : '';
1600 $last4 =~ s/[^0-9]//g;
1601 $last4 = substr($last4, 0, 4);
1602 my $em = defined $a{exp_month} ? $a{exp_month} : '';
1603 $em =~ s/[^0-9]//g;
1604 $em = 0 + ($em || 0);
1605 my $ey = defined $a{exp_year} ? $a{exp_year} : '';
1606 $ey =~ s/[^0-9]//g;
1607 $ey = 0 + ($ey || 0);
1608 my $spm = defined $a{stripe_payment_method_id} ? $a{stripe_payment_method_id} : '';
1609 $spm =~ s/[^a-zA-Z0-9_]//g;
1610 $spm = substr($spm, 0, 64);
1611 my $scu = defined $a{stripe_customer_id} ? $a{stripe_customer_id} : '';
1612 $scu =~ s/[^a-zA-Z0-9_]//g;
1613 $scu = substr($scu, 0, 64);
1614
1615 return 0 unless $spm;
1616
1617 # Reject duplicate stripe PM ids so a re-submit doesn't fan out
1618 # into multiple rows pointing at the same Stripe object.
1619 my $dupe = $db->db_readwrite($dbh, qq~
1620 SELECT id FROM `${DB}`.payment_methods
1621 WHERE user_id='$uid' AND stripe_payment_method_id='$spm'
1622 LIMIT 1
1623 ~, $ENV{SCRIPT_NAME}, __LINE__);
1624 return $dupe->{id} if ($dupe && $dupe->{id});
1625
1626 # First card on file becomes default automatically; otherwise leave
1627 # is_default alone and let the caller flip it explicitly.
1628 my $existing = $db->db_readwrite($dbh, qq~
1629 SELECT COUNT(*) AS n FROM `${DB}`.payment_methods WHERE user_id='$uid'
1630 ~, $ENV{SCRIPT_NAME}, __LINE__);
1631 my $is_default = ($existing && $existing->{n}) ? 0 : 1;
1632
1633 $db->db_readwrite($dbh, qq~
1634 INSERT INTO `${DB}`.payment_methods
1635 SET user_id='$uid',
1636 brand='$brand',
1637 last4='$last4',
1638 exp_month='$em',
1639 exp_year='$ey',
1640 is_default='$is_default',
1641 stripe_payment_method_id='$spm',
1642 stripe_customer_id='$scu',
1643 created_at=NOW()
1644 ~, $ENV{SCRIPT_NAME}, __LINE__);
1645
1646 my $new = $db->db_readwrite($dbh, qq~
1647 SELECT id FROM `${DB}`.payment_methods
1648 WHERE user_id='$uid' AND stripe_payment_method_id='$spm'
1649 LIMIT 1
1650 ~, $ENV{SCRIPT_NAME}, __LINE__);
1651 return $new ? $new->{id} : 0;
1652}
1653
1654# Promote one PM row to default and demote the others for this user.
1655# Stripe-side default is set by the caller (Stripe::set_customer_default_pm)
1656# so the next invoice charges this card.
1657sub set_default_payment_method {
1658 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1659 $uid =~ s/[^0-9]//g;
1660 $pm_id =~ s/[^0-9]//g;
1661 return 0 unless $uid && $pm_id;
1662 return 0 unless $self->schema_ready($db, $dbh, $DB);
1663
1664 my $pm = $self->payment_method_by_id($db, $dbh, $DB, $uid, $pm_id);
1665 return 0 unless $pm;
1666
1667 $db->db_readwrite($dbh, qq~
1668 UPDATE `${DB}`.payment_methods SET is_default=0 WHERE user_id='$uid'
1669 ~, $ENV{SCRIPT_NAME}, __LINE__);
1670 $db->db_readwrite($dbh, qq~
1671 UPDATE `${DB}`.payment_methods
1672 SET is_default=1
1673 WHERE id='$pm_id' AND user_id='$uid'
1674 ~, $ENV{SCRIPT_NAME}, __LINE__);
1675 return 1;
1676}
1677
1678# Drop a saved card. If the deleted row was the default and another
1679# card is still on file, promote the most-recently-added survivor.
1680# Returns the Stripe PM id so the caller can detach via the API.
1681sub delete_payment_method {
1682 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1683 $uid =~ s/[^0-9]//g;
1684 $pm_id =~ s/[^0-9]//g;
1685 return undef unless $uid && $pm_id;
1686 return undef unless $self->schema_ready($db, $dbh, $DB);
1687
1688 my $pm = $self->payment_method_by_id($db, $dbh, $DB, $uid, $pm_id);
1689 return undef unless $pm;
1690
1691 my $was_default = $pm->{is_default} ? 1 : 0;
1692 my $spm = $pm->{stripe_payment_method_id} || '';
1693
1694 $db->db_readwrite($dbh, qq~
1695 DELETE FROM `${DB}`.payment_methods
1696 WHERE id='$pm_id' AND user_id='$uid'
1697 ~, $ENV{SCRIPT_NAME}, __LINE__);
1698
1699 if ($was_default) {
1700 # Promote the newest remaining card to default so the seller
1701 # isn't left with "no default" silently.
1702 my $next = $db->db_readwrite($dbh, qq~
1703 SELECT id FROM `${DB}`.payment_methods
1704 WHERE user_id='$uid'
1705 ORDER BY id DESC
1706 LIMIT 1
1707 ~, $ENV{SCRIPT_NAME}, __LINE__);
1708 if ($next && $next->{id}) {
1709 my $nid = $next->{id};
1710 $db->db_readwrite($dbh, qq~
1711 UPDATE `${DB}`.payment_methods
1712 SET is_default=1
1713 WHERE id='$nid' AND user_id='$uid'
1714 ~, $ENV{SCRIPT_NAME}, __LINE__);
1715 }
1716 }
1717 return $spm;
1718}
1719
1720# Resolve (or lazily create) the Stripe customer for this user. Stores
1721# the resulting cus_xxx back on users.stripe_customer_id so subsequent
1722# calls are a no-op. Returns the cus_xxx string, or undef on failure.
1723#
1724# $stripe is a MODS::ShopCart::Stripe instance; injected so this module
1725# stays free of a direct Stripe require (lets tests stub it).
1726sub ensure_stripe_customer {
1727 my ($self, $db, $dbh, $DB, $userinfo, $stripe) = @_;
1728 return undef unless $userinfo && $userinfo->{user_id};
1729 my $uid = $userinfo->{user_id};
1730 $uid =~ s/[^0-9]//g;
1731 return undef unless $uid;
1732
1733 my $row = $db->db_readwrite($dbh, qq~
1734 SELECT stripe_customer_id, email FROM `${DB}`.users WHERE id='$uid' LIMIT 1
1735 ~, $ENV{SCRIPT_NAME}, __LINE__);
1736 return undef unless $row;
1737
1738 my $cus = $row->{stripe_customer_id} || '';
1739 return $cus if ($cus && $cus =~ /^cus_/);
1740
1741 return undef unless $stripe && $stripe->is_configured;
1742
1743 my $name = $userinfo->{display_name} || $userinfo->{username} || '';
1744 my $r = $stripe->create_customer(
1745 email => ($row->{email} || ''),
1746 name => $name,
1747 metadata => { user_id => $uid },
1748 );
1749 return undef if (!$r || $r->{error} || !$r->{id});
1750
1751 my $new_cus = $r->{id};
1752 my $safe = $new_cus;
1753 $safe =~ s/[^A-Za-z0-9_]//g;
1754 $db->db_readwrite($dbh, qq~
1755 UPDATE `${DB}`.users SET stripe_customer_id='$safe' WHERE id='$uid'
1756 ~, $ENV{SCRIPT_NAME}, __LINE__);
1757 return $new_cus;
1758}
1759
1760# ---- Platform-wide admin aggregates ----------------------------------
1761# Cash MRR/ARR -- only counts actual money received. Credit consumption
1762# is reported separately on the admin page so the user can never mistake
1763# "credit applied" for real revenue.
1764#
1765# Optional 4th/5th args: ($year, $month) scope every period-bound metric
1766# (cash received, credit consumed, outstanding credit at period close)
1767# to that calendar month. Omitting them defaults to the current month.
1768# Subscription counts (active/trialing/past_due/MRR/ARR/plan breakdown)
1769# are always point-in-time as of NOW -- they're not snapshotted history.
1770sub admin_summary {
1771 my ($self, $db, $dbh, $DB, $year, $month) = @_;
1772 my %out = (
1773 cash_revenue_mtd_cents => 0,
1774 credit_consumed_mtd_cents => 0,
1775 outstanding_credit_cents => 0,
1776 active_subs => 0,
1777 trialing_subs => 0,
1778 past_due_subs => 0,
1779 canceled_subs_30d => 0,
1780 mrr_cents => 0,
1781 arr_cents => 0,
1782 plan_breakdown => [],
1783 period_year => 0,
1784 period_month => 0,
1785 is_current_month => 0,
1786 );
1787 return \%out unless $self->schema_ready($db, $dbh, $DB);
1788
1789 # Resolve / sanitize the requested period. Defaults to current month.
1790 my @t = localtime(time);
1791 my $cur_year = $t[5] + 1900;
1792 my $cur_month = $t[4] + 1;
1793 $year =~ s/[^0-9]//g if defined $year;
1794 $month =~ s/[^0-9]//g if defined $month;
1795 $year = $cur_year unless $year && $year >= 2000 && $year <= 2100;
1796 $month = $cur_month unless $month && $month >= 1 && $month <= 12;
1797 my $is_current = ($year == $cur_year && $month == $cur_month) ? 1 : 0;
1798 $out{period_year} = $year;
1799 $out{period_month} = $month;
1800 $out{is_current_month} = $is_current;
1801
1802 # First-day and last-second of the requested calendar month. Used by
1803 # every period-scoped query below so all four tiles agree on bounds.
1804 my $period_start = sprintf('%04d-%02d-01 00:00:00', $year, $month);
1805 my $period_end_expr = "(DATE_ADD('$period_start', INTERVAL 1 MONTH) - INTERVAL 1 SECOND)";
1806
1807 my $r;
1808
1809 # Cash received in the requested calendar month.
1810 $r = $db->db_readwrite($dbh, qq~
1811 SELECT COALESCE(SUM(cash_paid_cents),0) AS n
1812 FROM `${DB}`.invoices
1813 WHERE status='paid'
1814 AND paid_at >= '$period_start'
1815 AND paid_at <= $period_end_expr
1816 ~, $ENV{SCRIPT_NAME}, __LINE__);
1817 $out{cash_revenue_mtd_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1818
1819 # Credit consumed in the requested calendar month.
1820 $r = $db->db_readwrite($dbh, qq~
1821 SELECT COALESCE(SUM(credit_applied_cents),0) AS n
1822 FROM `${DB}`.invoices
1823 WHERE status='paid'
1824 AND paid_at >= '$period_start'
1825 AND paid_at <= $period_end_expr
1826 ~, $ENV{SCRIPT_NAME}, __LINE__);
1827 $out{credit_consumed_mtd_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1828
1829 # Outstanding credit liability:
1830 # - current month -> live balance (sum of every ledger row to date)
1831 # - past month -> balance as of end of that month (sum of rows
1832 # with created_at <= period_end)
1833 my $cl_where = $is_current
1834 ? ''
1835 : "WHERE created_at <= $period_end_expr";
1836 $r = $db->db_readwrite($dbh, qq~
1837 SELECT COALESCE(SUM(amount_cents),0) AS n
1838 FROM `${DB}`.credit_ledger
1839 $cl_where
1840 ~, $ENV{SCRIPT_NAME}, __LINE__);
1841 $out{outstanding_credit_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1842
1843 # Subscription counts by status.
1844 foreach my $st (qw(active trialing past_due)) {
1845 my $col = "${st}_subs"; $col =~ s/^trialing_subs$/trialing_subs/;
1846 my $r2 = $db->db_readwrite($dbh, qq~
1847 SELECT COUNT(*) AS n FROM `${DB}`.subscriptions WHERE status='$st'
1848 ~, $ENV{SCRIPT_NAME}, __LINE__);
1849 $out{$col} = ($r2 && $r2->{n}) ? $r2->{n} : 0;
1850 }
1851 $r = $db->db_readwrite($dbh, qq~
1852 SELECT COUNT(*) AS n FROM `${DB}`.subscriptions
1853 WHERE status='canceled'
1854 AND canceled_at >= DATE_SUB(NOW(), INTERVAL 30 DAY)
1855 ~, $ENV{SCRIPT_NAME}, __LINE__);
1856 $out{canceled_subs_30d} = ($r && $r->{n}) ? $r->{n} : 0;
1857
1858 # MRR: monthly-cadence active/trialing subs at their plan's monthly
1859 # price + 1/12th of any annual-cadence active subs (annual price
1860 # comes from the plan's yearly_* fields, resolved by the same
1861 # rules compute_yearly_price_cents() uses).
1862 # Cadence now lives on the subscription itself, not the plan
1863 # (we collapsed the duplicate monthly/annual plan rows down to
1864 # one row per tier).
1865 $r = $db->db_readwrite($dbh, qq~
1866 SELECT COALESCE(SUM(p.price_cents),0) AS n
1867 FROM `${DB}`.subscriptions s
1868 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1869 WHERE s.status IN ('active','trialing','past_due')
1870 AND s.cadence='monthly'
1871 ~, $ENV{SCRIPT_NAME}, __LINE__);
1872 my $mrr_monthly = ($r && $r->{n}) ? $r->{n} : 0;
1873
1874 $r = $db->db_readwrite($dbh, qq~
1875 SELECT COALESCE(SUM(
1876 CASE p.yearly_mode
1877 WHEN 'explicit' THEN p.yearly_price_cents
1878 WHEN 'percent_off' THEN ROUND(p.price_cents * 12 * (100 - p.yearly_pct_off) / 100)
1879 WHEN 'dollars_off' THEN GREATEST(p.price_cents * 12 - p.yearly_off_cents, 0)
1880 ELSE 0
1881 END
1882 ), 0) AS n
1883 FROM `${DB}`.subscriptions s
1884 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1885 WHERE s.status IN ('active','trialing','past_due')
1886 AND s.cadence='annual'
1887 ~, $ENV{SCRIPT_NAME}, __LINE__);
1888 my $arr_annual = ($r && $r->{n}) ? $r->{n} : 0;
1889
1890 $out{mrr_cents} = $mrr_monthly + int($arr_annual / 12);
1891 $out{arr_cents} = $out{mrr_cents} * 12;
1892
1893 # Subscription invoices we *expect* to issue between now and the end
1894 # of the current calendar month. Used by the admin Projected
1895 # Earnings tile to add scheduled renewals on top of the linear
1896 # pace-only projection. Only meaningful for the current month -- for
1897 # past months the actual cash already landed, so there's nothing to
1898 # project.
1899 if ($is_current) {
1900 $r = $db->db_readwrite($dbh, qq~
1901 SELECT COALESCE(SUM(p.price_cents),0) AS n
1902 FROM `${DB}`.subscriptions s
1903 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1904 WHERE s.status IN ('active','trialing','past_due')
1905 AND s.next_invoice_at IS NOT NULL
1906 AND s.next_invoice_at > NOW()
1907 AND s.next_invoice_at <= LAST_DAY(CURDATE()) + INTERVAL 1 DAY
1908 ~, $ENV{SCRIPT_NAME}, __LINE__);
1909 $out{expected_subs_remaining_cents} = ($r && $r->{n}) ? $r->{n} : 0;
1910 } else {
1911 $out{expected_subs_remaining_cents} = 0;
1912 }
1913
1914 # Plan distribution (count per tier).
1915 my @pb = $db->db_readwrite_multiple($dbh, qq~
1916 SELECT p.tier, COUNT(*) AS n
1917 FROM `${DB}`.subscriptions s
1918 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1919 WHERE s.status IN ('active','trialing','past_due')
1920 GROUP BY p.tier
1921 ORDER BY p.tier ASC
1922 ~, $ENV{SCRIPT_NAME}, __LINE__);
1923 $out{plan_breakdown} = \@pb;
1924
1925 return \%out;
1926}
1927
1928# ---- Signups (free vs paid) ------------------------------------------
1929# "Paid" means current plan_tier is anything other than 'free' -- a
1930# decent proxy for "did this signup convert". A user who upgrades to
1931# paid later will retroactively count as a paid signup; we accept that
1932# trade-off here so we don't have to join the subscription history for
1933# every datapoint. created_at is the signup timestamp.
1934#
1935# Both daily and monthly variants return per-tier counts so the admin
1936# UI can hover-tooltip and click-modal them without an extra round trip.
1937#
1938# Post-consolidation: only 3 tiers (free / pro / business). The earlier
1939# 'starter' and 'studio' enum values were collapsed into pro/business
1940# via the users.plan_tier migration.
1941#
1942# admin_signups_daily(days) -> arrayref of
1943# { date, free, pro, business, paid, total }
1944# for the trailing N days (default 30), oldest first.
1945sub admin_signups_daily {
1946 my ($self, $db, $dbh, $DB, $days) = @_;
1947 return [] unless $self->schema_ready($db, $dbh, $DB);
1948 $days ||= 30; $days =~ s/[^0-9]//g; $days = 30 unless $days;
1949 $days = 365 if $days > 365;
1950
1951 my %by_date;
1952 my @rows = $db->db_readwrite_multiple($dbh, qq~
1953 SELECT DATE(created_at) AS d,
1954 SUM(CASE WHEN plan_tier='free' THEN 1 ELSE 0 END) AS free_n,
1955 SUM(CASE WHEN plan_tier='pro' THEN 1 ELSE 0 END) AS pro_n,
1956 SUM(CASE WHEN plan_tier='business' THEN 1 ELSE 0 END) AS business_n
1957 FROM `${DB}`.users
1958 WHERE created_at IS NOT NULL
1959 AND created_at >= DATE_SUB(CURDATE(), INTERVAL $days DAY)
1960 GROUP BY DATE(created_at)
1961 ~, $ENV{SCRIPT_NAME}, __LINE__);
1962 foreach my $r (@rows) { $by_date{$r->{d} || ''} = $r; }
1963
1964 my @out;
1965 my $now = time;
1966 for (my $i = $days - 1; $i >= 0; $i--) {
1967 my @t = localtime($now - $i * 86400);
1968 my $ymd = sprintf('%04d-%02d-%02d', $t[5]+1900, $t[4]+1, $t[3]);
1969 my $r = $by_date{$ymd} || {};
1970 my $free = ($r->{free_n} || 0) + 0;
1971 my $pro = ($r->{pro_n} || 0) + 0;
1972 my $business = ($r->{business_n} || 0) + 0;
1973 my $paid = $pro + $business;
1974 push @out, {
1975 date => $ymd,
1976 free => $free,
1977 pro => $pro,
1978 business => $business,
1979 paid => $paid,
1980 total => $free + $paid,
1981 };
1982 }
1983 return \@out;
1984}
1985
1986# admin_signups_monthly(months) -> arrayref of
1987# { month, free, pro, business, paid, total }
1988# for the trailing N months (default 12), oldest first. month is YYYY-MM.
1989sub admin_signups_monthly {
1990 my ($self, $db, $dbh, $DB, $months) = @_;
1991 return [] unless $self->schema_ready($db, $dbh, $DB);
1992 $months ||= 12; $months =~ s/[^0-9]//g; $months = 12 unless $months;
1993 $months = 60 if $months > 60;
1994
1995 my %by_month;
1996 my @rows = $db->db_readwrite_multiple($dbh, qq~
1997 SELECT DATE_FORMAT(created_at, '%Y-%m') AS m,
1998 SUM(CASE WHEN plan_tier='free' THEN 1 ELSE 0 END) AS free_n,
1999 SUM(CASE WHEN plan_tier='pro' THEN 1 ELSE 0 END) AS pro_n,
2000 SUM(CASE WHEN plan_tier='business' THEN 1 ELSE 0 END) AS business_n
2001 FROM `${DB}`.users
2002 WHERE created_at IS NOT NULL
2003 AND created_at >= DATE_SUB(DATE_FORMAT(CURDATE(),'%Y-%m-01'), INTERVAL ($months - 1) MONTH)
2004 GROUP BY DATE_FORMAT(created_at, '%Y-%m')
2005 ~, $ENV{SCRIPT_NAME}, __LINE__);
2006 foreach my $r (@rows) { $by_month{$r->{m} || ''} = $r; }
2007
2008 my @t = localtime(time);
2009 my $y = $t[5] + 1900;
2010 my $m = $t[4] + 1;
2011 my @out;
2012 for (my $i = $months - 1; $i >= 0; $i--) {
2013 my $back_m = $m - $i;
2014 my $back_y = $y;
2015 while ($back_m <= 0) { $back_m += 12; $back_y -= 1; }
2016 my $ym = sprintf('%04d-%02d', $back_y, $back_m);
2017 my $r = $by_month{$ym} || {};
2018 my $free = ($r->{free_n} || 0) + 0;
2019 my $pro = ($r->{pro_n} || 0) + 0;
2020 my $business = ($r->{business_n} || 0) + 0;
2021 my $paid = $pro + $business;
2022 push @out, {
2023 month => $ym,
2024 free => $free,
2025 pro => $pro,
2026 business => $business,
2027 paid => $paid,
2028 total => $free + $paid,
2029 };
2030 }
2031 return \@out;
2032}
2033
2034# Recent invoices across every user (admin page).
2035sub admin_recent_invoices {
2036 my ($self, $db, $dbh, $DB, $limit) = @_;
2037 return () unless $self->schema_ready($db, $dbh, $DB);
2038 $limit ||= 25;
2039 $limit =~ s/[^0-9]//g;
2040 $limit = 25 unless $limit;
2041 $limit = 200 if $limit > 200;
2042
2043 return $db->db_readwrite_multiple($dbh, qq~
2044 SELECT i.id, i.invoice_number, i.user_id,
2045 i.amount_due_cents, i.credit_applied_cents, i.cash_paid_cents,
2046 i.currency, i.status, i.issued_at, i.paid_at, i.created_at,
2047 u.email, u.display_name
2048 FROM `${DB}`.invoices i
2049 LEFT JOIN `${DB}`.users u ON u.id = i.user_id
2050 ORDER BY COALESCE(i.issued_at, i.created_at) DESC, i.id DESC
2051 LIMIT $limit
2052 ~, $ENV{SCRIPT_NAME}, __LINE__);
2053}
2054
2055# Accounts with a non-zero credit balance. Used on the admin page so
2056# staff can see who has outstanding credit at a glance.
2057sub admin_credit_holders {
2058 my ($self, $db, $dbh, $DB, $limit) = @_;
2059 return () unless $self->schema_ready($db, $dbh, $DB);
2060 $limit ||= 25;
2061 $limit =~ s/[^0-9]//g;
2062 $limit = 25 unless $limit;
2063 $limit = 200 if $limit > 200;
2064
2065 return $db->db_readwrite_multiple($dbh, qq~
2066 SELECT u.id AS user_id, u.email, u.display_name,
2067 COALESCE(SUM(cl.amount_cents),0) AS balance_cents
2068 FROM `${DB}`.users u
2069 JOIN `${DB}`.credit_ledger cl ON cl.user_id = u.id
2070 GROUP BY u.id
2071 HAVING balance_cents <> 0
2072 ORDER BY balance_cents DESC
2073 LIMIT $limit
2074 ~, $ENV{SCRIPT_NAME}, __LINE__);
2075}
2076
2077# ---- Formatting helpers ---------------------------------------------
2078sub fmt_money {
2079 my ($self, $cents, $currency) = @_;
2080 $currency ||= 'USD';
2081 $cents = 0 unless defined $cents;
2082 my $sign = ($cents < 0) ? '-' : '';
2083 my $abs = abs($cents);
2084 my $dollars = sprintf('%.2f', $abs / 100);
2085 # Insert thousands separators into the dollar portion.
2086 my ($whole, $frac) = split('\.', $dollars);
2087 1 while $whole =~ s/(\d)(\d{3})(?!\d)/$1,$2/;
2088 return $sign . '$' . $whole . '.' . $frac;
2089}
2090
2091sub fmt_cadence {
2092 my ($self, $cadence) = @_;
2093 return 'monthly' unless $cadence;
2094 return $cadence eq 'annual' ? 'year' : 'month';
2095}
2096
2097# ---- Admin Packages CRUD --------------------------------------------
2098# Used by admin_packages.cgi / admin_packages_action.cgi. None of these
2099# touch entitlements directly -- callers set_plan_features after a
2100# successful create/update.
2101sub _esc_sql {
2102 my $s = shift; $s = '' unless defined $s;
2103 $s =~ s/\\/\\\\/g; $s =~ s/'/''/g; return $s;
2104}
2105
2106# Create a new billing_plans row. Returns the new row id on success
2107# or (0, $error_message) on failure.
2108sub create_plan {
2109 my ($self, $db, $dbh, $DB, %a) = @_;
2110 return (0, 'billing schema not migrated') unless $self->schema_ready($db, $dbh, $DB);
2111 return (0, 'plan columns not migrated') unless $self->plan_columns_ready($db, $dbh, $DB);
2112
2113 my $tier = lc(_esc_sql($a{tier} || '')); $tier =~ s/[^a-z0-9_\-]//g;
2114 my $cadence = lc(_esc_sql($a{cadence} || 'monthly'));
2115 my $display_name = _esc_sql($a{display_name} || '');
2116 my $tagline = _esc_sql($a{tagline} || '');
2117 my $cta_label = _esc_sql($a{cta_label} || '');
2118 my $features_raw = _esc_sql($a{features} || '');
2119 my $currency = uc(_esc_sql($a{currency} || 'USD')); $currency = substr($currency,0,3);
2120 my $price = $a{price_cents}; $price =~ s/[^0-9]//g; $price = 0 unless $price;
2121 my $sort_order = $a{sort_order}; $sort_order =~ s/[^0-9-]//g; $sort_order = 0 unless length $sort_order;
2122 my $is_featured = $a{is_featured} ? 1 : 0;
2123 my $is_active = (defined $a{is_active} ? $a{is_active} : 1) ? 1 : 0;
2124
2125 return (0, 'cadence must be monthly or annual')
2126 unless $cadence eq 'monthly' || $cadence eq 'annual';
2127 return (0, 'tier is required') unless $tier;
2128 return (0, 'display name is required') unless length $display_name;
2129
2130 # Block duplicate (tier, cadence). DB has a UNIQUE KEY but we want
2131 # a friendlier error message than the driver default.
2132 my $dup = $db->db_readwrite($dbh, qq~
2133 SELECT id FROM `${DB}`.billing_plans
2134 WHERE tier='$tier' AND cadence='$cadence' LIMIT 1
2135 ~, $ENV{SCRIPT_NAME}, __LINE__);
2136 return (0, "A $tier $cadence plan already exists.")
2137 if $dup && $dup->{id};
2138
2139 # Yearly-pricing fields (added post-consolidation). New plans
2140 # default to no yearly upgrade unless the caller specifies a mode.
2141 my %ymode_ok = map { $_ => 1 } qw(none percent_off dollars_off explicit);
2142 my $ymode = defined $a{yearly_mode} ? $a{yearly_mode} : 'none';
2143 $ymode = 'none' unless $ymode_ok{$ymode};
2144 my $ypct = defined $a{yearly_pct_off} ? int($a{yearly_pct_off} || 0) : 0;
2145 my $yoff = defined $a{yearly_off_cents} ? int($a{yearly_off_cents} || 0) : 0;
2146 my $yprc = defined $a{yearly_price_cents} ? int($a{yearly_price_cents} || 0) : 0;
2147 $ypct = 0 if $ypct < 0;
2148 $ypct = 90 if $ypct > 90;
2149
2150 my $r = $db->db_readwrite($dbh, qq~
2151 INSERT INTO `${DB}`.billing_plans
2152 SET tier='$tier',
2153 cadence='$cadence',
2154 display_name='$display_name',
2155 tagline='$tagline',
2156 cta_label='$cta_label',
2157 price_cents='$price',
2158 yearly_mode='$ymode',
2159 yearly_pct_off='$ypct',
2160 yearly_off_cents='$yoff',
2161 yearly_price_cents='$yprc',
2162 currency='$currency',
2163 features='$features_raw',
2164 sort_order='$sort_order',
2165 is_featured='$is_featured',
2166 is_active='$is_active'
2167 ~, $ENV{SCRIPT_NAME}, __LINE__);
2168 my $new_id = ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0;
2169 return ($new_id, '');
2170}
2171
2172# Update an existing plan. $plan_id must exist or this is a no-op.
2173# Same return shape as create_plan: (id, error).
2174sub update_plan {
2175 my ($self, $db, $dbh, $DB, $plan_id, %a) = @_;
2176 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2177 return (0, 'plan id required') unless $plan_id;
2178 return (0, 'billing schema not migrated') unless $self->schema_ready($db, $dbh, $DB);
2179 return (0, 'plan columns not migrated') unless $self->plan_columns_ready($db, $dbh, $DB);
2180
2181 my $existing = $self->plan_by_id($db, $dbh, $DB, $plan_id);
2182 return (0, 'plan not found') unless $existing && $existing->{id};
2183
2184 my $tier = lc(_esc_sql($a{tier} || $existing->{tier}));
2185 $tier =~ s/[^a-z0-9_\-]//g;
2186 my $cadence = lc(_esc_sql($a{cadence} || $existing->{cadence} || 'monthly'));
2187 my $display_name = _esc_sql(defined $a{display_name} ? $a{display_name} : $existing->{display_name});
2188 my $tagline = _esc_sql(defined $a{tagline} ? $a{tagline} : ($existing->{tagline} || ''));
2189 my $cta_label = _esc_sql(defined $a{cta_label} ? $a{cta_label} : ($existing->{cta_label} || ''));
2190 my $features_raw = _esc_sql(defined $a{features} ? $a{features} : ($existing->{features} || ''));
2191 my $currency = uc(_esc_sql($a{currency} || $existing->{currency} || 'USD'));
2192 $currency = substr($currency,0,3);
2193 my $price = defined $a{price_cents} ? $a{price_cents} : ($existing->{price_cents} || 0);
2194 $price =~ s/[^0-9]//g; $price = 0 unless $price;
2195 my $sort_order = defined $a{sort_order} ? $a{sort_order} : ($existing->{sort_order} || 0);
2196 $sort_order =~ s/[^0-9-]//g; $sort_order = 0 unless length $sort_order;
2197 my $is_featured = $a{is_featured} ? 1 : 0;
2198 my $is_active = (defined $a{is_active} ? $a{is_active} : 1) ? 1 : 0;
2199
2200 return (0, 'cadence must be monthly or annual')
2201 unless $cadence eq 'monthly' || $cadence eq 'annual';
2202 return (0, 'tier is required') unless $tier;
2203 return (0, 'display name is required') unless length $display_name;
2204
2205 # Guard the unique key when (tier, cadence) changes.
2206 if ($tier ne $existing->{tier} || $cadence ne ($existing->{cadence} || 'monthly')) {
2207 my $dup = $db->db_readwrite($dbh, qq~
2208 SELECT id FROM `${DB}`.billing_plans
2209 WHERE tier='$tier' AND cadence='$cadence' AND id<>'$plan_id'
2210 LIMIT 1
2211 ~, $ENV{SCRIPT_NAME}, __LINE__);
2212 return (0, "A $tier $cadence plan already exists.")
2213 if $dup && $dup->{id};
2214 }
2215
2216 # Yearly-pricing fields. If caller didn't pass them, keep the
2217 # existing values (so old code paths that only edit name/price
2218 # don't accidentally wipe a plan's yearly config).
2219 my %ymode_ok = map { $_ => 1 } qw(none percent_off dollars_off explicit);
2220 my $ymode = defined $a{yearly_mode} ? $a{yearly_mode} : ($existing->{yearly_mode} || 'none');
2221 $ymode = 'none' unless $ymode_ok{$ymode};
2222 my $ypct = defined $a{yearly_pct_off} ? int($a{yearly_pct_off} || 0) : int($existing->{yearly_pct_off} || 0);
2223 my $yoff = defined $a{yearly_off_cents} ? int($a{yearly_off_cents} || 0) : int($existing->{yearly_off_cents} || 0);
2224 my $yprc = defined $a{yearly_price_cents} ? int($a{yearly_price_cents} || 0) : int($existing->{yearly_price_cents} || 0);
2225 $ypct = 0 if $ypct < 0;
2226 $ypct = 90 if $ypct > 90;
2227
2228 $db->db_readwrite($dbh, qq~
2229 UPDATE `${DB}`.billing_plans
2230 SET tier='$tier',
2231 cadence='$cadence',
2232 display_name='$display_name',
2233 tagline='$tagline',
2234 cta_label='$cta_label',
2235 price_cents='$price',
2236 yearly_mode='$ymode',
2237 yearly_pct_off='$ypct',
2238 yearly_off_cents='$yoff',
2239 yearly_price_cents='$yprc',
2240 currency='$currency',
2241 features='$features_raw',
2242 sort_order='$sort_order',
2243 is_featured='$is_featured',
2244 is_active='$is_active'
2245 WHERE id='$plan_id'
2246 ~, $ENV{SCRIPT_NAME}, __LINE__);
2247 return ($plan_id, '');
2248}
2249
2250# Soft-delete (deactivate) a plan. We don't hard-delete because
2251# subscriptions FK ON DELETE RESTRICT and historical rows must keep
2252# the price/tier label intact.
2253sub deactivate_plan {
2254 my ($self, $db, $dbh, $DB, $plan_id) = @_;
2255 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2256 return 0 unless $plan_id;
2257 return 0 unless $self->schema_ready($db, $dbh, $DB);
2258 $db->db_readwrite($dbh, qq~
2259 UPDATE `${DB}`.billing_plans SET is_active=0 WHERE id='$plan_id'
2260 ~, $ENV{SCRIPT_NAME}, __LINE__);
2261 return 1;
2262}
2263
2264sub activate_plan {
2265 my ($self, $db, $dbh, $DB, $plan_id) = @_;
2266 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2267 return 0 unless $plan_id;
2268 return 0 unless $self->schema_ready($db, $dbh, $DB);
2269 $db->db_readwrite($dbh, qq~
2270 UPDATE `${DB}`.billing_plans SET is_active=1 WHERE id='$plan_id'
2271 ~, $ENV{SCRIPT_NAME}, __LINE__);
2272 return 1;
2273}
2274
22751;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help