Diff -- /var/www/vhosts/3dshawn.com/abforge.3dshawn.com/MODS/ABForge/Billing.pm

O Operator
Diff

/var/www/vhosts/3dshawn.com/abforge.3dshawn.com/MODS/ABForge/Billing.pm

added on local at 2026-07-11 18:19:39

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