Diff -- /var/www/vhosts/3dshawn.com/repricer.3dshawn.com/MODS/RePricer/Billing.pm
Diff

/var/www/vhosts/3dshawn.com/repricer.3dshawn.com/MODS/RePricer/Billing.pm

added on local at 2026-07-01 21:47:10

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