Diff -- /var/www/vhosts/3dshawn.com/affiliate.3dshawn.com/MODS/AffSoft/Billing.pm
Diff

/var/www/vhosts/3dshawn.com/affiliate.3dshawn.com/MODS/AffSoft/Billing.pm

added on local at 2026-07-01 13:47:27

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