Diff -- /var/www/vhosts/3dshawn.com/crm.3dshawn.com/MODS/ContactForge/Billing.pm
Diff

/var/www/vhosts/3dshawn.com/crm.3dshawn.com/MODS/ContactForge/Billing.pm

added on local at 2026-07-01 15:02:51

Added
+2318
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 336f48da7f58
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::ContactForge::Billing;
2#======================================================================
3# ContactForge - 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 { key => 'campaigns',
40 name => 'Campaigns',
41 blurb => 'Bulk email + drip sequences to contact segments',
42 details => 'Send broadcast or scheduled email campaigns to any contact segment. Requires a connected BYO SMTP provider (Settings -> Email Provider) and counts against the plan\'s monthly send cap. When OFF, /campaigns.cgi 403s and the Campaigns sidebar entry is hidden.',
43 enforced_in => 'Sidebar (Campaigns), /campaigns.cgi, /campaign_action.cgi',
44 icon => 'send',
45 module => 'campaigns' },
46 { key => 'automations',
47 name => 'Automations',
48 blurb => 'Trigger-based workflows + drip sequences',
49 details => 'Time-based or event-triggered workflows that move deals through pipelines, fire emails, or update fields automatically. When OFF, the Workflows sidebar entry is hidden and triggers stop firing.',
50 enforced_in => 'Sidebar (Workflows), /workflows.cgi',
51 icon => 'activity',
52 module => 'workflows' },
53 { key => 'api_access',
54 name => 'API access',
55 blurb => 'REST API + webhooks for custom integrations',
56 details => 'Personal API tokens, REST endpoints for contacts/deals/activities, and outbound webhooks. When OFF, API endpoints return 403 and the API Docs sidebar entry is hidden.',
57 enforced_in => 'Sidebar (API Docs), /api/*, webhook delivery',
58 icon => 'team',
59 module => 'api' },
60 { key => 'reports',
61 name => 'Reports',
62 blurb => 'Pipeline, deals, activity, and revenue dashboards',
63 details => 'Unlocks the reports console -- pipeline velocity, win/loss, activity volume, revenue by source. When OFF, the Reports sidebar entry is hidden and dashboards fall back to a single-tile summary.',
64 enforced_in => 'Sidebar (Reports), /reports.cgi',
65 icon => 'chart',
66 module => 'reports' },
67 { key => 'audit_log_export',
68 name => 'Audit log export',
69 blurb => 'Download every change for compliance / reviews',
70 details => 'CSV download of the audit_log table (every create / update / delete with actor + timestamp). When OFF, the Audit tab in Admin is read-only with no export button.',
71 enforced_in => '/admin.cgi audit tab',
72 icon => 'documents',
73 module => 'audit' },
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# Live column names: slug, name, billing_period, features_json. The rest
132# of the codebase historically read $row->{tier}/{display_name}/{cadence}/
133# {features}, so we alias here -- one source of truth in the DB, no
134# downstream code churn. New caps + overage + enterprise + BYO-SMTP
135# columns from the pricing-v4 migration are appended.
136sub _plan_select_cols {
137 my ($self, $db, $dbh, $DB) = @_;
138 return q{id,
139 slug AS tier, slug,
140 name AS display_name, name,
141 billing_period AS cadence, billing_period,
142 features_json AS features, features_json,
143 price_cents, yearly_price_cents, currency,
144 contacts_included, users_included, pipelines_included, emails_included,
145 seat_overage_cents, contact_overage_per_1k_cents, email_overage_per_1k_cents,
146 tagline, cta_label, is_featured, is_enterprise, requires_byo_smtp,
147 is_active, sort_order};
148}
149
150# --------------------------------------------------------------
151# Compute the effective yearly price in cents for a plan row,
152# given the yearly_mode + the relevant input field. Returns 0
153# when the plan offers no yearly option (yearly_mode='none' or
154# monthly price is 0 -- e.g. the Free tier).
155# --------------------------------------------------------------
156sub compute_yearly_price_cents {
157 my ($self, $plan) = @_;
158 return 0 unless ref($plan) eq 'HASH';
159 my $monthly = int($plan->{price_cents} || 0);
160 return 0 if $monthly <= 0;
161 # Live schema stores the yearly price explicitly; admin sets it
162 # directly in the Packages console. 0 = annual not offered.
163 return int($plan->{yearly_price_cents} || 0);
164}
165
166sub list_plans {
167 my ($self, $db, $dbh, $DB, $include_inactive) = @_;
168 return () unless $self->schema_ready($db, $dbh, $DB);
169
170 my $where = $include_inactive ? '' : 'WHERE is_active=1';
171 my $cols = $self->_plan_select_cols($db, $dbh, $DB);
172 my @rows = $db->db_readwrite_multiple($dbh, qq~
173 SELECT $cols
174 FROM `${DB}`.billing_plans
175 $where
176 ORDER BY sort_order ASC, id ASC
177 ~, $ENV{SCRIPT_NAME}, __LINE__);
178 return @rows;
179}
180
181sub plan_by_id {
182 my ($self, $db, $dbh, $DB, $plan_id) = @_;
183 $plan_id =~ s/[^0-9]//g if defined $plan_id;
184 return {} unless $plan_id;
185 return {} unless $self->schema_ready($db, $dbh, $DB);
186
187 my $cols = $self->_plan_select_cols($db, $dbh, $DB);
188 my $r = $db->db_readwrite($dbh, qq~
189 SELECT $cols
190 FROM `${DB}`.billing_plans
191 WHERE id='$plan_id'
192 LIMIT 1
193 ~, $ENV{SCRIPT_NAME}, __LINE__);
194 return ($r && $r->{id}) ? $r : {};
195}
196
197# ---- Plan -> feature entitlements -----------------------------------
198# Returns a hashref { feature_key => 1, ... } of features the given
199# plan includes. Empty hash if the table isn't migrated yet (callers
200# treat that as "no entitlements" -- effectively all features locked).
201sub plan_feature_set {
202 my ($self, $db, $dbh, $DB, $plan_id) = @_;
203 my %out;
204 $plan_id =~ s/[^0-9]//g if defined $plan_id;
205 return \%out unless $plan_id;
206 return \%out unless $self->plan_features_ready($db, $dbh, $DB);
207
208 my @rows = $db->db_readwrite_multiple($dbh, qq~
209 SELECT feature_key
210 FROM `${DB}`.plan_features
211 WHERE plan_id='$plan_id' AND is_included=1
212 ~, $ENV{SCRIPT_NAME}, __LINE__);
213 foreach my $r (@rows) { $out{ $r->{feature_key} } = 1; }
214 return \%out;
215}
216
217# Set the entitlements for a plan. $included_aref is a list of
218# feature_keys to mark included; every catalog key NOT in that list
219# is written as is_included=0. Caller is responsible for validating
220# that $plan_id refers to a real row.
221sub set_plan_features {
222 my ($self, $db, $dbh, $DB, $plan_id, $included_aref) = @_;
223 $plan_id =~ s/[^0-9]//g if defined $plan_id;
224 return 0 unless $plan_id;
225 return 0 unless $self->plan_features_ready($db, $dbh, $DB);
226
227 my %wanted = map { $_ => 1 } @{ $included_aref || [] };
228 foreach my $f ($self->feature_catalog) {
229 my $key = $f->{key};
230 my $inc = $wanted{$key} ? 1 : 0;
231 # REPLACE because PK is (plan_id, feature_key).
232 $db->db_readwrite($dbh, qq~
233 REPLACE INTO `${DB}`.plan_features
234 SET plan_id='$plan_id',
235 feature_key='$key',
236 is_included='$inc'
237 ~, $ENV{SCRIPT_NAME}, __LINE__);
238 }
239 return 1;
240}
241
242# True if the user's active subscription's plan includes the given
243# feature_key. Free-tier users still get features whose plan includes
244# them. If no subscription row exists at all we still honor the Free
245# plan's entitlements (lowest sort_order, price_cents=0).
246sub user_has_feature {
247 my ($self, $db, $dbh, $DB, $uid, $feature_key) = @_;
248 $uid =~ s/[^0-9]//g if defined $uid;
249 return 0 unless $uid && $feature_key;
250 return 0 unless $self->plan_features_ready($db, $dbh, $DB);
251
252 my $sub = $self->active_subscription($db, $dbh, $DB, $uid);
253 my $plan_id = $sub->{plan_id};
254 if (!$plan_id) {
255 # Fall back to the lowest-priced active plan (Free seat).
256 my $r = $db->db_readwrite($dbh, qq~
257 SELECT id FROM `${DB}`.billing_plans
258 WHERE is_active=1
259 ORDER BY price_cents ASC, sort_order ASC
260 LIMIT 1
261 ~, $ENV{SCRIPT_NAME}, __LINE__);
262 $plan_id = ($r && $r->{id}) ? $r->{id} : 0;
263 }
264 return 0 unless $plan_id;
265
266 my $set = $self->plan_feature_set($db, $dbh, $DB, $plan_id);
267 return $set->{$feature_key} ? 1 : 0;
268}
269
270# Returns the full feature catalog rolled up with the user's current
271# entitlement state, for rendering on settings.cgi. Each row:
272# { key, name, blurb, icon, module, included (0/1), plan_label }
273sub user_feature_entitlements {
274 my ($self, $db, $dbh, $DB, $uid) = @_;
275 $uid =~ s/[^0-9]//g if defined $uid;
276 my @out;
277
278 my $plan_label = 'Free';
279 my $plan_id = 0;
280 if ($uid && $self->schema_ready($db, $dbh, $DB)) {
281 my $sub = $self->active_subscription($db, $dbh, $DB, $uid);
282 if ($sub->{plan_id}) {
283 $plan_id = $sub->{plan_id};
284 $plan_label = $sub->{display_name} || ucfirst($sub->{tier} || 'Free');
285 } else {
286 my $r = $db->db_readwrite($dbh, qq~
287 SELECT id, name AS display_name, slug AS tier
288 FROM `${DB}`.billing_plans
289 WHERE is_active=1
290 ORDER BY price_cents ASC, sort_order ASC
291 LIMIT 1
292 ~, $ENV{SCRIPT_NAME}, __LINE__);
293 if ($r && $r->{id}) {
294 $plan_id = $r->{id};
295 $plan_label = $r->{display_name} || ucfirst($r->{tier} || 'Free');
296 }
297 }
298 }
299 my $set = $plan_id ? $self->plan_feature_set($db, $dbh, $DB, $plan_id) : {};
300
301 foreach my $f ($self->feature_catalog) {
302 push @out, {
303 key => $f->{key},
304 name => $f->{name},
305 blurb => $f->{blurb},
306 icon => $f->{icon},
307 module => $f->{module},
308 included => $set->{ $f->{key} } ? 1 : 0,
309 locked => $set->{ $f->{key} } ? 0 : 1,
310 plan_label => $plan_label,
311 };
312 }
313 return @out;
314}
315
316sub plan_by_tier_cadence {
317 my ($self, $db, $dbh, $DB, $tier, $cadence) = @_;
318 $cadence ||= 'monthly';
319 return {} unless $self->schema_ready($db, $dbh, $DB);
320
321 my %tier_ok = map { $_ => 1 } qw(pro business);
322 my %cadence_ok = map { $_ => 1 } qw(monthly annual);
323 return {} unless $tier_ok{$tier} && $cadence_ok{$cadence};
324
325 # Post-consolidation: one row per tier. The requested cadence picks
326 # which price to surface as `price_cents`. For annual requests,
327 # compute_yearly_price_cents() resolves the percent/dollars/explicit
328 # mode; for monthly, we return the row's price_cents as-is.
329 my $r = $db->db_readwrite($dbh, qq~
330 SELECT id, slug AS tier, name AS display_name, price_cents, currency,
331 yearly_price_cents,
332 features_json AS features
333 FROM `${DB}`.billing_plans
334 WHERE slug='$tier' AND is_active=1
335 LIMIT 1
336 ~, $ENV{SCRIPT_NAME}, __LINE__);
337 return {} unless $r && $r->{id};
338
339 $r->{cadence} = $cadence;
340 if ($cadence eq 'annual') {
341 my $yp = $self->compute_yearly_price_cents($r);
342 return {} unless $yp > 0; # tier offers no yearly upgrade
343 $r->{price_cents} = $yp;
344 }
345 return $r;
346}
347
348# ---- Subscription lookup --------------------------------------------
349# Returns the user's most-recently-modified non-canceled subscription
350# or {} if none. We always allow at most one active subscription per
351# user; downgrades/upgrades update the existing row rather than create
352# new ones, which keeps invoice history tied to a single sub_id.
353sub active_subscription {
354 my ($self, $db, $dbh, $DB, $uid) = @_;
355 $uid =~ s/[^0-9]//g;
356 return {} unless $uid;
357 return {} unless $self->schema_ready($db, $dbh, $DB);
358
359 # Pending-downgrade columns ship in a follow-on migration; guard
360 # so existing installs that haven't run the ALTER still load.
361 my $pend_cols = $self->_pending_cols_ready($db, $dbh, $DB)
362 ? ', s.pending_plan_id, s.pending_cadence, s.pending_change_at'
363 : '';
364
365 # `cadence` lives on the SUBSCRIPTION row (post-consolidation),
366 # not the plan. Returns the monthly base price; callers that need
367 # the yearly price for an annual sub should run the plan through
368 # compute_yearly_price_cents() themselves.
369 my $r = $db->db_readwrite($dbh, qq~
370 SELECT s.id, s.user_id, s.plan_id, s.cadence, s.status,
371 s.started_at, s.trial_end, s.next_invoice_at,
372 s.canceled_at, s.cancel_at_period_end,
373 s.last_charge_failed_at, s.last_charge_error$pend_cols,
374 p.slug AS tier, p.name AS display_name, p.price_cents, p.currency,
375 p.features_json AS features, p.yearly_price_cents,
376 p.is_enterprise, p.contacts_included, p.users_included, p.emails_included
377 FROM `${DB}`.subscriptions s
378 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
379 WHERE s.user_id='$uid'
380 AND s.status IN ('trialing','active','past_due','paused')
381 ORDER BY s.updated_at DESC
382 LIMIT 1
383 ~, $ENV{SCRIPT_NAME}, __LINE__);
384 return {} unless ($r && $r->{id});
385
386 # If a deferred change had a pending_plan attached, fetch the
387 # display_name / tier of the *target* plan so the UI can render
388 # "Scheduled to downgrade to Pro on 2026-06-12". One small
389 # query; only runs when an active pending change exists.
390 if ($pend_cols && $r->{pending_plan_id}) {
391 my $pp = $self->plan_by_id($db, $dbh, $DB, $r->{pending_plan_id});
392 if ($pp && $pp->{id}) {
393 $r->{pending_plan_display_name} = $pp->{display_name};
394 $r->{pending_plan_tier} = $pp->{tier};
395 $r->{pending_plan_price_cents} = $pp->{price_cents};
396 }
397 }
398 return $r;
399}
400
401# Cached probe for the pending-change columns on subscriptions. Cheap
402# (single information_schema row) and stable per request, so we stash
403# the result on $self and reuse for every active_subscription() call.
404sub _pending_cols_ready {
405 my ($self, $db, $dbh, $DB) = @_;
406 return $self->{_pend_ready} if exists $self->{_pend_ready};
407 my $r = $db->db_readwrite($dbh, qq~
408 SELECT COUNT(*) AS n FROM information_schema.columns
409 WHERE table_schema='$DB' AND table_name='subscriptions'
410 AND column_name='pending_plan_id'
411 ~, $ENV{SCRIPT_NAME}, __LINE__);
412 $self->{_pend_ready} = ($r && $r->{n}) ? 1 : 0;
413 return $self->{_pend_ready};
414}
415
416# Tier rank for upgrade-vs-downgrade comparisons. Higher = more
417# valuable. Anything outside the known set is treated as 0 so we
418# never miscategorize a custom-tier slug as an upgrade.
419#
420# Post pricing-v3 (2-tier paid):
421# business = 2 (highest paid tier)
422# pro = 1
423# anything else (legacy free / pre-v3 paid slugs) = 0
424# We keep the legacy slugs returning 0 so a stale session that still
425# reads `plan_tier='free'` doesn't crash upgrade math.
426sub tier_rank {
427 my ($self, $tier) = @_;
428 return 0 unless defined $tier;
429 return 2 if $tier eq 'business';
430 return 1 if $tier eq 'pro';
431 return 0; # legacy / 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 rep 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 rep 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::ContactForge::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 = "ContactForge - 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.slug AS 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 rep'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.slug AS 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 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 $base_amount = $self->compute_charge_cents($sub, $cadence);
1115 return 0 unless $base_amount > 0;
1116
1117 # Post pricing-v4 overage: Business accrues per-1k contact, per-seat,
1118 # and per-1k campaign-send overage above the included caps. Pro has
1119 # no overage (enforce() hard-blocks at the cap). Caps module computes
1120 # the line items; we write one invoice_items row per resource for
1121 # transparency, plus the base subscription line item.
1122 my @overage_items;
1123 eval {
1124 require MODS::ContactForge::Caps;
1125 my $caps = MODS::ContactForge::Caps->new;
1126 my $items = $caps->overage_line_items($db, $dbh, $DB, $uid);
1127 @overage_items = @{ $items || [] };
1128 };
1129 my $overage_total = 0;
1130 foreach my $li (@overage_items) { $overage_total += $li->{total_cents}; }
1131
1132 my $subtotal = $base_amount + $overage_total;
1133 my $period_start_sql = "DATE('$anchor')";
1134 my $period_end_sql = "DATE_SUB(DATE_ADD(DATE('$anchor'), INTERVAL $interval), INTERVAL 1 DAY)";
1135
1136 # Live invoices schema: `number` (UNIQUE), `subtotal_cents`,
1137 # `discount_cents`, `tax_cents`, `total_cents`, `status` (enum
1138 # draft|open|paid|...). The legacy column names this code used
1139 # (invoice_number/amount_due_cents/credit_applied_cents/cash_paid_cents)
1140 # don't exist in production -- this rewrite uses the live shape.
1141 $db->db_readwrite($dbh, qq~
1142 INSERT INTO `${DB}`.invoices
1143 SET user_id='$uid',
1144 subscription_id='$sid',
1145 number='$num',
1146 subtotal_cents='$subtotal',
1147 discount_cents=0,
1148 tax_cents=0,
1149 total_cents='$subtotal',
1150 currency='USD',
1151 period_start=$period_start_sql,
1152 period_end=$period_end_sql,
1153 status='open',
1154 issued_at=NOW(),
1155 created_at=NOW()
1156 ~, $ENV{SCRIPT_NAME}, __LINE__);
1157
1158 my $r = $db->db_readwrite($dbh, qq~
1159 SELECT id FROM `${DB}`.invoices WHERE number='$num' LIMIT 1
1160 ~, $ENV{SCRIPT_NAME}, __LINE__);
1161 my $invoice_id = ($r && $r->{id}) ? $r->{id} : 0;
1162 return 0 unless $invoice_id;
1163
1164 # Write line items: 1 subscription base + 1 per overage resource.
1165 my $plan_label = ($sub->{display_name} || ucfirst($sub->{tier} || 'Plan'))
1166 . " subscription (" . ($cadence eq 'annual' ? 'annual' : 'monthly') . ")";
1167 $plan_label =~ s/'/''/g;
1168 $db->db_readwrite($dbh, qq~
1169 INSERT INTO `${DB}`.invoice_items
1170 (invoice_id, item_type, description, quantity, unit_cents,
1171 amount_cents, period_start, period_end, sort_order)
1172 VALUES
1173 ('$invoice_id', 'subscription', '$plan_label', 1, '$base_amount',
1174 '$base_amount', $period_start_sql, $period_end_sql, 10)
1175 ~, $ENV{SCRIPT_NAME}, __LINE__);
1176
1177 my $order = 20;
1178 foreach my $li (@overage_items) {
1179 my $desc = $li->{description}; $desc =~ s/'/''/g;
1180 my $qty = int($li->{billable_units} || 0);
1181 my $unit = int($li->{per_unit_cents} || 0);
1182 my $amt = int($li->{total_cents} || 0);
1183 next unless $amt > 0;
1184 $db->db_readwrite($dbh, qq~
1185 INSERT INTO `${DB}`.invoice_items
1186 (invoice_id, item_type, description, quantity, unit_cents,
1187 amount_cents, period_start, period_end, sort_order)
1188 VALUES
1189 ('$invoice_id', 'addon', '$desc', '$qty', '$unit',
1190 '$amt', $period_start_sql, $period_end_sql, '$order')
1191 ~, $ENV{SCRIPT_NAME}, __LINE__);
1192 $order += 10;
1193 }
1194
1195 return $invoice_id;
1196}
1197
1198# Idempotent credit application. If credit_applied_cents is already > 0
1199# we treat it as already applied and skip. Otherwise: read balance,
1200# clamp to amount_due, write the -ledger row, update the invoice.
1201sub apply_credit_to_invoice {
1202 my ($self, $db, $dbh, $DB, $invoice_id) = @_;
1203 return 0 unless $self->schema_ready($db, $dbh, $DB);
1204 $invoice_id =~ s/[^0-9]//g;
1205 return 0 unless $invoice_id;
1206
1207 my $inv = $db->db_readwrite($dbh, qq~
1208 SELECT id, user_id, amount_due_cents, credit_applied_cents, status
1209 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1210 ~, $ENV{SCRIPT_NAME}, __LINE__);
1211 return 0 unless ($inv && $inv->{id});
1212 return $inv->{credit_applied_cents} if $inv->{credit_applied_cents} > 0;
1213 return 0 if $inv->{status} eq 'paid' || $inv->{status} eq 'void';
1214
1215 my $uid = $inv->{user_id};
1216 my $amount = $inv->{amount_due_cents} || 0;
1217 my $bal = $self->credit_balance_cents($db, $dbh, $DB, $uid);
1218 return 0 if $bal <= 0;
1219
1220 my $apply = ($bal < $amount) ? $bal : $amount;
1221 return 0 unless $apply > 0;
1222
1223 my $neg = 0 - $apply;
1224 my $note = 'Applied to invoice #' . $invoice_id;
1225 $note =~ s/'/''/g;
1226
1227 $db->db_readwrite($dbh, qq~
1228 INSERT INTO `${DB}`.credit_ledger
1229 SET user_id='$uid',
1230 amount_cents='$neg',
1231 reason='applied_to_invoice',
1232 related_invoice_id='$invoice_id',
1233 note='$note',
1234 created_at=NOW()
1235 ~, $ENV{SCRIPT_NAME}, __LINE__);
1236
1237 $db->db_readwrite($dbh, qq~
1238 UPDATE `${DB}`.invoices
1239 SET credit_applied_cents='$apply'
1240 WHERE id='$invoice_id'
1241 ~, $ENV{SCRIPT_NAME}, __LINE__);
1242
1243 return $apply;
1244}
1245
1246# Get the user's default Stripe payment_method id. Returns (cus_id,
1247# pm_id) -- both required by Stripe::create_subscription_charge.
1248sub default_payment_method_for_user {
1249 my ($self, $db, $dbh, $DB, $uid) = @_;
1250 $uid =~ s/[^0-9]//g;
1251 return (undef, undef) unless $uid;
1252 return (undef, undef) unless $self->schema_ready($db, $dbh, $DB);
1253 my $r = $db->db_readwrite($dbh, qq~
1254 SELECT stripe_customer_id, stripe_payment_method_id
1255 FROM `${DB}`.payment_methods
1256 WHERE user_id='$uid'
1257 ORDER BY is_default DESC, id DESC
1258 LIMIT 1
1259 ~, $ENV{SCRIPT_NAME}, __LINE__);
1260 return (undef, undef) unless $r;
1261 return ($r->{stripe_customer_id}, $r->{stripe_payment_method_id});
1262}
1263
1264# Update an invoice to paid + advance the subscription's next_invoice_at.
1265# Called by the worker on Stripe 'succeeded' AND by the webhook on
1266# payment_intent.succeeded -- whichever fires first wins; the other
1267# is a no-op via the status='paid' early-return.
1268sub mark_invoice_paid {
1269 my ($self, $db, $dbh, $DB, $invoice_id, %p) = @_;
1270 return 0 unless $self->schema_ready($db, $dbh, $DB);
1271 $invoice_id =~ s/[^0-9]//g;
1272 return 0 unless $invoice_id;
1273
1274 my $inv = $db->db_readwrite($dbh, qq~
1275 SELECT id, user_id, subscription_id, amount_due_cents,
1276 credit_applied_cents, status
1277 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1278 ~, $ENV{SCRIPT_NAME}, __LINE__);
1279 return 0 unless ($inv && $inv->{id});
1280 return 1 if $inv->{status} eq 'paid'; # idempotent no-op
1281
1282 my $cash = defined $p{cash_paid_cents} ? $p{cash_paid_cents}
1283 : ($inv->{amount_due_cents} - ($inv->{credit_applied_cents} || 0));
1284 $cash = 0 if $cash < 0;
1285 $cash =~ s/[^0-9]//g;
1286
1287 my $pi = defined $p{stripe_payment_intent_id} ? $p{stripe_payment_intent_id} : '';
1288 $pi =~ s/[^A-Za-z0-9_]//g;
1289 my $pi_sql = length($pi) ? "stripe_payment_intent_id='$pi'," : '';
1290
1291 $db->db_readwrite($dbh, qq~
1292 UPDATE `${DB}`.invoices
1293 SET status='paid',
1294 cash_paid_cents='$cash',
1295 $pi_sql
1296 paid_at=NOW(),
1297 failure_reason=NULL
1298 WHERE id='$invoice_id'
1299 ~, $ENV{SCRIPT_NAME}, __LINE__);
1300
1301 # Advance the sub: next_invoice_at += cadence, clear past_due
1302 # error, status='active'. We use a fresh read so we don't trust
1303 # a stale cadence cached on the worker.
1304 if ($inv->{subscription_id}) {
1305 my $sid = $inv->{subscription_id}; $sid =~ s/[^0-9]//g;
1306 my $s = $db->db_readwrite($dbh, qq~
1307 SELECT cadence FROM `${DB}`.subscriptions WHERE id='$sid' LIMIT 1
1308 ~, $ENV{SCRIPT_NAME}, __LINE__);
1309 my $cad = ($s && $s->{cadence} && $s->{cadence} eq 'annual') ? '1 YEAR' : '1 MONTH';
1310 $db->db_readwrite($dbh, qq~
1311 UPDATE `${DB}`.subscriptions
1312 SET status='active',
1313 last_charge_failed_at=NULL,
1314 last_charge_error=NULL,
1315 next_invoice_at=DATE_ADD(next_invoice_at, INTERVAL $cad)
1316 WHERE id='$sid'
1317 ~, $ENV{SCRIPT_NAME}, __LINE__);
1318 }
1319 return 1;
1320}
1321
1322sub mark_invoice_failed {
1323 my ($self, $db, $dbh, $DB, $invoice_id, %p) = @_;
1324 return 0 unless $self->schema_ready($db, $dbh, $DB);
1325 $invoice_id =~ s/[^0-9]//g;
1326 return 0 unless $invoice_id;
1327
1328 my $reason = defined $p{reason} ? $p{reason} : '';
1329 $reason =~ s/'/''/g;
1330 $reason = substr($reason, 0, 480);
1331 my $pi = defined $p{stripe_payment_intent_id} ? $p{stripe_payment_intent_id} : '';
1332 $pi =~ s/[^A-Za-z0-9_]//g;
1333 my $pi_sql = length($pi) ? "stripe_payment_intent_id='$pi'," : '';
1334
1335 $db->db_readwrite($dbh, qq~
1336 UPDATE `${DB}`.invoices
1337 SET status='failed',
1338 $pi_sql
1339 failure_reason='$reason'
1340 WHERE id='$invoice_id'
1341 ~, $ENV{SCRIPT_NAME}, __LINE__);
1342
1343 my $inv = $db->db_readwrite($dbh, qq~
1344 SELECT subscription_id FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1345 ~, $ENV{SCRIPT_NAME}, __LINE__);
1346 if ($inv && $inv->{subscription_id}) {
1347 my $sid = $inv->{subscription_id}; $sid =~ s/[^0-9]//g;
1348 $db->db_readwrite($dbh, qq~
1349 UPDATE `${DB}`.subscriptions
1350 SET status='past_due',
1351 last_charge_failed_at=NOW(),
1352 last_charge_error='$reason'
1353 WHERE id='$sid'
1354 ~, $ENV{SCRIPT_NAME}, __LINE__);
1355 }
1356 return 1;
1357}
1358
1359# Orchestrates one invoice through to a terminal status. Returns a
1360# hash describing the outcome:
1361# { mode => 'paid_by_credit' | 'paid_by_card' | 'failed' | 'noop',
1362# reason => '...', payment_intent_id => '...' }
1363# Safe to call multiple times for the same invoice.
1364sub charge_invoice {
1365 my ($self, $db, $dbh, $DB, $invoice_id, $stripe) = @_;
1366 return { mode => 'noop', reason => 'schema' } unless $self->schema_ready($db, $dbh, $DB);
1367 $invoice_id =~ s/[^0-9]//g;
1368 return { mode => 'noop', reason => 'bad_id' } unless $invoice_id;
1369
1370 my $inv = $db->db_readwrite($dbh, qq~
1371 SELECT id, user_id, subscription_id, amount_due_cents,
1372 credit_applied_cents, status, stripe_payment_intent_id
1373 FROM `${DB}`.invoices WHERE id='$invoice_id' LIMIT 1
1374 ~, $ENV{SCRIPT_NAME}, __LINE__);
1375 return { mode => 'noop', reason => 'not_found' } unless ($inv && $inv->{id});
1376 return { mode => 'noop', reason => 'already_paid' } if $inv->{status} eq 'paid';
1377 return { mode => 'noop', reason => 'void' } if $inv->{status} eq 'void';
1378
1379 my $amount = $inv->{amount_due_cents} || 0;
1380 my $credit = $inv->{credit_applied_cents} || 0;
1381 my $cash = $amount - $credit;
1382 $cash = 0 if $cash < 0;
1383
1384 # Fully covered by credit: paid immediately, no Stripe call.
1385 if ($cash == 0) {
1386 $self->mark_invoice_paid($db, $dbh, $DB, $invoice_id,
1387 cash_paid_cents => 0);
1388 return { mode => 'paid_by_credit' };
1389 }
1390
1391 # Stripe not configured -> mark past_due with a clear reason so
1392 # the admin sees it on /admin_billing.cgi.
1393 unless ($stripe && $stripe->is_configured) {
1394 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1395 reason => 'Stripe is not configured. Add keys in Software Configuration to enable charges.');
1396 return { mode => 'failed', reason => 'stripe_unconfigured' };
1397 }
1398
1399 my ($cus, $pm) = $self->default_payment_method_for_user($db, $dbh, $DB, $inv->{user_id});
1400 unless ($cus && $pm) {
1401 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1402 reason => 'No payment method on file. Add a card on the Billing page.');
1403 return { mode => 'failed', reason => 'no_pm' };
1404 }
1405
1406 my $r = $stripe->create_subscription_charge(
1407 amount_cents => $cash,
1408 customer => $cus,
1409 payment_method => $pm,
1410 invoice_id => $invoice_id,
1411 user_id => $inv->{user_id},
1412 subscription_id => ($inv->{subscription_id} || ''),
1413 idempotency_key => "sub_invoice_$invoice_id",
1414 description => "ContactForge subscription invoice #$invoice_id",
1415 );
1416
1417 if ($r && $r->{error}) {
1418 # Stripe-side reject (card declined, 3DS required off-session,
1419 # etc.) -- the API surfaces the human reason via error.message.
1420 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1421 reason => $r->{error},
1422 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} : '',
1423 );
1424 return { mode => 'failed', reason => $r->{error} };
1425 }
1426
1427 my $status = $r->{status} || '';
1428 my $pi_id = $r->{id} || '';
1429
1430 if ($status eq 'succeeded') {
1431 $self->mark_invoice_paid($db, $dbh, $DB, $invoice_id,
1432 cash_paid_cents => $cash,
1433 stripe_payment_intent_id => $pi_id);
1434 return { mode => 'paid_by_card', payment_intent_id => $pi_id };
1435 }
1436
1437 # Anything else (requires_action / requires_payment_method /
1438 # processing) is treated as a failure on the off-session path.
1439 # The webhook will mark it paid later if 'processing' eventually
1440 # succeeds.
1441 $self->mark_invoice_failed($db, $dbh, $DB, $invoice_id,
1442 reason => "Stripe returned status '$status' (off-session charge could not complete).",
1443 stripe_payment_intent_id => $pi_id);
1444 return { mode => 'failed', reason => $status, payment_intent_id => $pi_id };
1445}
1446
1447# Cancel a previously-scheduled deferred plan change. The rep
1448# clicked "Keep my current plan" while the downgrade was queued.
1449sub clear_pending_change {
1450 my ($self, $db, $dbh, $DB, $uid) = @_;
1451 $uid =~ s/[^0-9]//g;
1452 return 0 unless $uid;
1453 return 0 unless $self->schema_ready($db, $dbh, $DB);
1454 return 0 unless $self->_pending_cols_ready($db, $dbh, $DB);
1455 $db->db_readwrite($dbh, qq~
1456 UPDATE `${DB}`.subscriptions
1457 SET pending_plan_id=NULL,
1458 pending_cadence=NULL,
1459 pending_change_at=NULL
1460 WHERE user_id='$uid'
1461 AND pending_plan_id IS NOT NULL
1462 ~, $ENV{SCRIPT_NAME}, __LINE__);
1463 return 1;
1464}
1465
1466# ---- Credit ledger ---------------------------------------------------
1467# Balance = simple SUM over the append-only ledger. Always recomputed
1468# from the source of truth rather than cached.
1469sub credit_balance_cents {
1470 my ($self, $db, $dbh, $DB, $uid) = @_;
1471 $uid =~ s/[^0-9]//g;
1472 return 0 unless $uid;
1473 return 0 unless $self->schema_ready($db, $dbh, $DB);
1474
1475 my $r = $db->db_readwrite($dbh, qq~
1476 SELECT COALESCE(SUM(amount_cents),0) AS n
1477 FROM `${DB}`.credit_ledger
1478 WHERE user_id='$uid'
1479 ~, $ENV{SCRIPT_NAME}, __LINE__);
1480 return ($r && defined $r->{n}) ? $r->{n} : 0;
1481}
1482
1483sub credit_history {
1484 my ($self, $db, $dbh, $DB, $uid, $limit) = @_;
1485 $uid =~ s/[^0-9]//g;
1486 return () unless $uid;
1487 return () unless $self->schema_ready($db, $dbh, $DB);
1488
1489 $limit ||= 25;
1490 $limit =~ s/[^0-9]//g;
1491 $limit = 25 unless $limit;
1492 $limit = 200 if $limit > 200;
1493
1494 return $db->db_readwrite_multiple($dbh, qq~
1495 SELECT id, amount_cents, reason, related_invoice_id,
1496 granted_by_user_id, note, created_at
1497 FROM `${DB}`.credit_ledger
1498 WHERE user_id='$uid'
1499 ORDER BY created_at DESC, id DESC
1500 LIMIT $limit
1501 ~, $ENV{SCRIPT_NAME}, __LINE__);
1502}
1503
1504# Grant credit. Used by:
1505# - admin refund-as-credit action (reason='refund')
1506# - admin manual grant (reason='manual_grant')
1507# - promotional bonus (reason='promotional')
1508# Returns the new credit_ledger row id (or 0 on failure).
1509sub grant_credit {
1510 my ($self, $db, $dbh, $DB, %a) = @_;
1511 return 0 unless $self->schema_ready($db, $dbh, $DB);
1512
1513 my $uid = $a{user_id}; $uid =~ s/[^0-9]//g;
1514 my $amount = $a{amount_cents}; $amount =~ s/[^0-9-]//g;
1515 my $reason = $a{reason} || 'manual_grant';
1516 my $admin = defined $a{granted_by_user_id} ? $a{granted_by_user_id} : '';
1517 $admin =~ s/[^0-9]//g;
1518 my $rel = defined $a{related_invoice_id} ? $a{related_invoice_id} : '';
1519 $rel =~ s/[^0-9]//g;
1520 my $note = defined $a{note} ? $a{note} : '';
1521 $note =~ s/'/''/g;
1522 $note = substr($note, 0, 480);
1523
1524 return 0 unless $uid && $amount;
1525 my %ok = map { $_ => 1 } qw(refund manual_grant promotional reversal);
1526 return 0 unless $ok{$reason};
1527
1528 my $admin_sql = $admin eq '' ? 'NULL' : "'$admin'";
1529 my $rel_sql = $rel eq '' ? 'NULL' : "'$rel'";
1530
1531 my $r = $db->db_readwrite($dbh, qq~
1532 INSERT INTO `${DB}`.credit_ledger
1533 SET user_id='$uid',
1534 amount_cents='$amount',
1535 reason='$reason',
1536 related_invoice_id=$rel_sql,
1537 granted_by_user_id=$admin_sql,
1538 note='$note'
1539 ~, $ENV{SCRIPT_NAME}, __LINE__);
1540 return ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0;
1541}
1542
1543# ---- Invoice listing -------------------------------------------------
1544sub list_invoices {
1545 my ($self, $db, $dbh, $DB, $uid, $limit) = @_;
1546 $uid =~ s/[^0-9]//g;
1547 return () unless $uid;
1548 return () unless $self->schema_ready($db, $dbh, $DB);
1549
1550 $limit ||= 24;
1551 $limit =~ s/[^0-9]//g;
1552 $limit = 24 unless $limit;
1553 $limit = 200 if $limit > 200;
1554
1555 return $db->db_readwrite_multiple($dbh, qq~
1556 SELECT id, invoice_number, period_start, period_end,
1557 amount_due_cents, credit_applied_cents, cash_paid_cents,
1558 currency, status, failure_reason,
1559 issued_at, paid_at, created_at
1560 FROM `${DB}`.invoices
1561 WHERE user_id='$uid'
1562 ORDER BY COALESCE(issued_at, created_at) DESC, id DESC
1563 LIMIT $limit
1564 ~, $ENV{SCRIPT_NAME}, __LINE__);
1565}
1566
1567# Single invoice (for the receipt drilldown).
1568sub get_invoice {
1569 my ($self, $db, $dbh, $DB, $invoice_id, $uid_for_ownership) = @_;
1570 $invoice_id =~ s/[^0-9]//g;
1571 return {} unless $invoice_id;
1572 return {} unless $self->schema_ready($db, $dbh, $DB);
1573
1574 my $owner_sql = '';
1575 if (defined $uid_for_ownership) {
1576 my $u = $uid_for_ownership; $u =~ s/[^0-9]//g;
1577 $owner_sql = " AND user_id='$u'" if $u;
1578 }
1579
1580 my $r = $db->db_readwrite($dbh, qq~
1581 SELECT id, user_id, subscription_id, invoice_number,
1582 period_start, period_end,
1583 amount_due_cents, credit_applied_cents, cash_paid_cents,
1584 currency, status, failure_reason,
1585 issued_at, paid_at, created_at
1586 FROM `${DB}`.invoices
1587 WHERE id='$invoice_id' $owner_sql
1588 LIMIT 1
1589 ~, $ENV{SCRIPT_NAME}, __LINE__);
1590 return ($r && $r->{id}) ? $r : {};
1591}
1592
1593sub list_invoice_items {
1594 my ($self, $db, $dbh, $DB, $invoice_id) = @_;
1595 $invoice_id =~ s/[^0-9]//g;
1596 return () unless $invoice_id;
1597 return () unless $self->schema_ready($db, $dbh, $DB);
1598
1599 return $db->db_readwrite_multiple($dbh, qq~
1600 SELECT id, kind, description, amount_cents, quantity
1601 FROM `${DB}`.invoice_items
1602 WHERE invoice_id='$invoice_id'
1603 ORDER BY id ASC
1604 ~, $ENV{SCRIPT_NAME}, __LINE__);
1605}
1606
1607# ---- Payment methods -------------------------------------------------
1608sub list_payment_methods {
1609 my ($self, $db, $dbh, $DB, $uid) = @_;
1610 $uid =~ s/[^0-9]//g;
1611 return () unless $uid;
1612 return () unless $self->schema_ready($db, $dbh, $DB);
1613
1614 return $db->db_readwrite_multiple($dbh, qq~
1615 SELECT id, brand, last4, exp_month, exp_year, is_default,
1616 stripe_payment_method_id, stripe_customer_id, created_at
1617 FROM `${DB}`.payment_methods
1618 WHERE user_id='$uid'
1619 ORDER BY is_default DESC, id DESC
1620 ~, $ENV{SCRIPT_NAME}, __LINE__);
1621}
1622
1623# Single PM row scoped by (user_id, id). Used by the delete and
1624# set-default actions before we let a request touch the row -- enforces
1625# the rep can only see their own cards.
1626sub payment_method_by_id {
1627 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1628 $uid =~ s/[^0-9]//g;
1629 $pm_id =~ s/[^0-9]//g;
1630 return undef unless $uid && $pm_id;
1631 return undef unless $self->schema_ready($db, $dbh, $DB);
1632 my $r = $db->db_readwrite($dbh, qq~
1633 SELECT id, user_id, brand, last4, exp_month, exp_year,
1634 is_default, stripe_payment_method_id, stripe_customer_id
1635 FROM `${DB}`.payment_methods
1636 WHERE id='$pm_id' AND user_id='$uid'
1637 LIMIT 1
1638 ~, $ENV{SCRIPT_NAME}, __LINE__);
1639 return ($r && $r->{id}) ? $r : undef;
1640}
1641
1642# Insert a new payment_methods row after Stripe Elements + SetupIntent
1643# have produced a confirmed payment_method id. Caller has already done
1644# the Stripe API retrieve to pull brand/last4/exp -- we never touch the
1645# PAN here. First card auto-promotes to default; subsequent cards can
1646# be promoted explicitly via set_default_payment_method().
1647sub save_payment_method {
1648 my ($self, $db, $dbh, $DB, $uid, %a) = @_;
1649 $uid =~ s/[^0-9]//g;
1650 return 0 unless $uid;
1651 return 0 unless $self->schema_ready($db, $dbh, $DB);
1652
1653 my $brand = defined $a{brand} ? $a{brand} : '';
1654 $brand =~ s/[^a-zA-Z_\-]//g;
1655 $brand = substr($brand, 0, 40);
1656 my $last4 = defined $a{last4} ? $a{last4} : '';
1657 $last4 =~ s/[^0-9]//g;
1658 $last4 = substr($last4, 0, 4);
1659 my $em = defined $a{exp_month} ? $a{exp_month} : '';
1660 $em =~ s/[^0-9]//g;
1661 $em = 0 + ($em || 0);
1662 my $ey = defined $a{exp_year} ? $a{exp_year} : '';
1663 $ey =~ s/[^0-9]//g;
1664 $ey = 0 + ($ey || 0);
1665 my $spm = defined $a{stripe_payment_method_id} ? $a{stripe_payment_method_id} : '';
1666 $spm =~ s/[^a-zA-Z0-9_]//g;
1667 $spm = substr($spm, 0, 64);
1668 my $scu = defined $a{stripe_customer_id} ? $a{stripe_customer_id} : '';
1669 $scu =~ s/[^a-zA-Z0-9_]//g;
1670 $scu = substr($scu, 0, 64);
1671
1672 return 0 unless $spm;
1673
1674 # Reject duplicate stripe PM ids so a re-submit doesn't fan out
1675 # into multiple rows pointing at the same Stripe object.
1676 my $dupe = $db->db_readwrite($dbh, qq~
1677 SELECT id FROM `${DB}`.payment_methods
1678 WHERE user_id='$uid' AND stripe_payment_method_id='$spm'
1679 LIMIT 1
1680 ~, $ENV{SCRIPT_NAME}, __LINE__);
1681 return $dupe->{id} if ($dupe && $dupe->{id});
1682
1683 # First card on file becomes default automatically; otherwise leave
1684 # is_default alone and let the caller flip it explicitly.
1685 my $existing = $db->db_readwrite($dbh, qq~
1686 SELECT COUNT(*) AS n FROM `${DB}`.payment_methods WHERE user_id='$uid'
1687 ~, $ENV{SCRIPT_NAME}, __LINE__);
1688 my $is_default = ($existing && $existing->{n}) ? 0 : 1;
1689
1690 $db->db_readwrite($dbh, qq~
1691 INSERT INTO `${DB}`.payment_methods
1692 SET user_id='$uid',
1693 brand='$brand',
1694 last4='$last4',
1695 exp_month='$em',
1696 exp_year='$ey',
1697 is_default='$is_default',
1698 stripe_payment_method_id='$spm',
1699 stripe_customer_id='$scu',
1700 created_at=NOW()
1701 ~, $ENV{SCRIPT_NAME}, __LINE__);
1702
1703 my $new = $db->db_readwrite($dbh, qq~
1704 SELECT id FROM `${DB}`.payment_methods
1705 WHERE user_id='$uid' AND stripe_payment_method_id='$spm'
1706 LIMIT 1
1707 ~, $ENV{SCRIPT_NAME}, __LINE__);
1708 return $new ? $new->{id} : 0;
1709}
1710
1711# Promote one PM row to default and demote the others for this user.
1712# Stripe-side default is set by the caller (Stripe::set_customer_default_pm)
1713# so the next invoice charges this card.
1714sub set_default_payment_method {
1715 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1716 $uid =~ s/[^0-9]//g;
1717 $pm_id =~ s/[^0-9]//g;
1718 return 0 unless $uid && $pm_id;
1719 return 0 unless $self->schema_ready($db, $dbh, $DB);
1720
1721 my $pm = $self->payment_method_by_id($db, $dbh, $DB, $uid, $pm_id);
1722 return 0 unless $pm;
1723
1724 $db->db_readwrite($dbh, qq~
1725 UPDATE `${DB}`.payment_methods SET is_default=0 WHERE user_id='$uid'
1726 ~, $ENV{SCRIPT_NAME}, __LINE__);
1727 $db->db_readwrite($dbh, qq~
1728 UPDATE `${DB}`.payment_methods
1729 SET is_default=1
1730 WHERE id='$pm_id' AND user_id='$uid'
1731 ~, $ENV{SCRIPT_NAME}, __LINE__);
1732 return 1;
1733}
1734
1735# Drop a saved card. If the deleted row was the default and another
1736# card is still on file, promote the most-recently-added survivor.
1737# Returns the Stripe PM id so the caller can detach via the API.
1738sub delete_payment_method {
1739 my ($self, $db, $dbh, $DB, $uid, $pm_id) = @_;
1740 $uid =~ s/[^0-9]//g;
1741 $pm_id =~ s/[^0-9]//g;
1742 return undef unless $uid && $pm_id;
1743 return undef unless $self->schema_ready($db, $dbh, $DB);
1744
1745 my $pm = $self->payment_method_by_id($db, $dbh, $DB, $uid, $pm_id);
1746 return undef unless $pm;
1747
1748 my $was_default = $pm->{is_default} ? 1 : 0;
1749 my $spm = $pm->{stripe_payment_method_id} || '';
1750
1751 $db->db_readwrite($dbh, qq~
1752 DELETE FROM `${DB}`.payment_methods
1753 WHERE id='$pm_id' AND user_id='$uid'
1754 ~, $ENV{SCRIPT_NAME}, __LINE__);
1755
1756 if ($was_default) {
1757 # Promote the newest remaining card to default so the rep
1758 # isn't left with "no default" silently.
1759 my $next = $db->db_readwrite($dbh, qq~
1760 SELECT id FROM `${DB}`.payment_methods
1761 WHERE user_id='$uid'
1762 ORDER BY id DESC
1763 LIMIT 1
1764 ~, $ENV{SCRIPT_NAME}, __LINE__);
1765 if ($next && $next->{id}) {
1766 my $nid = $next->{id};
1767 $db->db_readwrite($dbh, qq~
1768 UPDATE `${DB}`.payment_methods
1769 SET is_default=1
1770 WHERE id='$nid' AND user_id='$uid'
1771 ~, $ENV{SCRIPT_NAME}, __LINE__);
1772 }
1773 }
1774 return $spm;
1775}
1776
1777# Resolve (or lazily create) the Stripe customer for this user. Stores
1778# the resulting cus_xxx back on users.stripe_customer_id so subsequent
1779# calls are a no-op. Returns the cus_xxx string, or undef on failure.
1780#
1781# $stripe is a MODS::ContactForge::Stripe instance; injected so this module
1782# stays free of a direct Stripe require (lets tests stub it).
1783sub ensure_stripe_customer {
1784 my ($self, $db, $dbh, $DB, $userinfo, $stripe) = @_;
1785 return undef unless $userinfo && $userinfo->{user_id};
1786 my $uid = $userinfo->{user_id};
1787 $uid =~ s/[^0-9]//g;
1788 return undef unless $uid;
1789
1790 my $row = $db->db_readwrite($dbh, qq~
1791 SELECT stripe_customer_id, email FROM `${DB}`.users WHERE id='$uid' LIMIT 1
1792 ~, $ENV{SCRIPT_NAME}, __LINE__);
1793 return undef unless $row;
1794
1795 my $cus = $row->{stripe_customer_id} || '';
1796 return $cus if ($cus && $cus =~ /^cus_/);
1797
1798 return undef unless $stripe && $stripe->is_configured;
1799
1800 my $name = $userinfo->{display_name} || $userinfo->{username} || '';
1801 my $r = $stripe->create_customer(
1802 email => ($row->{email} || ''),
1803 name => $name,
1804 metadata => { user_id => $uid },
1805 );
1806 return undef if (!$r || $r->{error} || !$r->{id});
1807
1808 my $new_cus = $r->{id};
1809 my $safe = $new_cus;
1810 $safe =~ s/[^A-Za-z0-9_]//g;
1811 $db->db_readwrite($dbh, qq~
1812 UPDATE `${DB}`.users SET stripe_customer_id='$safe' WHERE id='$uid'
1813 ~, $ENV{SCRIPT_NAME}, __LINE__);
1814 return $new_cus;
1815}
1816
1817# ---- Platform-wide admin aggregates ----------------------------------
1818# Cash MRR/ARR -- only counts actual money received. Credit consumption
1819# is reported separately on the admin page so the user can never mistake
1820# "credit applied" for real revenue.
1821#
1822# Optional 4th/5th args: ($year, $month) scope every period-bound metric
1823# (cash received, credit consumed, outstanding credit at period close)
1824# to that calendar month. Omitting them defaults to the current month.
1825# Subscription counts (active/trialing/past_due/MRR/ARR/plan breakdown)
1826# are always point-in-time as of NOW -- they're not snapshotted history.
1827sub admin_summary {
1828 my ($self, $db, $dbh, $DB, $year, $month) = @_;
1829 my %out = (
1830 cash_revenue_mtd_cents => 0,
1831 credit_consumed_mtd_cents => 0,
1832 outstanding_credit_cents => 0,
1833 active_subs => 0,
1834 trialing_subs => 0,
1835 past_due_subs => 0,
1836 canceled_subs_30d => 0,
1837 mrr_cents => 0,
1838 arr_cents => 0,
1839 plan_breakdown => [],
1840 period_year => 0,
1841 period_month => 0,
1842 is_current_month => 0,
1843 );
1844 return \%out unless $self->schema_ready($db, $dbh, $DB);
1845
1846 # Resolve / sanitize the requested period. Defaults to current month.
1847 my @t = localtime(time);
1848 my $cur_year = $t[5] + 1900;
1849 my $cur_month = $t[4] + 1;
1850 $year =~ s/[^0-9]//g if defined $year;
1851 $month =~ s/[^0-9]//g if defined $month;
1852 $year = $cur_year unless $year && $year >= 2000 && $year <= 2100;
1853 $month = $cur_month unless $month && $month >= 1 && $month <= 12;
1854 my $is_current = ($year == $cur_year && $month == $cur_month) ? 1 : 0;
1855 $out{period_year} = $year;
1856 $out{period_month} = $month;
1857 $out{is_current_month} = $is_current;
1858
1859 # First-day and last-second of the requested calendar month. Used by
1860 # every period-scoped query below so all four tiles agree on bounds.
1861 my $period_start = sprintf('%04d-%02d-01 00:00:00', $year, $month);
1862 my $period_end_expr = "(DATE_ADD('$period_start', INTERVAL 1 MONTH) - INTERVAL 1 SECOND)";
1863
1864 my $r;
1865
1866 # Cash received in the requested calendar month.
1867 $r = $db->db_readwrite($dbh, qq~
1868 SELECT COALESCE(SUM(cash_paid_cents),0) AS n
1869 FROM `${DB}`.invoices
1870 WHERE status='paid'
1871 AND paid_at >= '$period_start'
1872 AND paid_at <= $period_end_expr
1873 ~, $ENV{SCRIPT_NAME}, __LINE__);
1874 $out{cash_revenue_mtd_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1875
1876 # Credit consumed in the requested calendar month.
1877 $r = $db->db_readwrite($dbh, qq~
1878 SELECT COALESCE(SUM(credit_applied_cents),0) AS n
1879 FROM `${DB}`.invoices
1880 WHERE status='paid'
1881 AND paid_at >= '$period_start'
1882 AND paid_at <= $period_end_expr
1883 ~, $ENV{SCRIPT_NAME}, __LINE__);
1884 $out{credit_consumed_mtd_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1885
1886 # Outstanding credit liability:
1887 # - current month -> live balance (sum of every ledger row to date)
1888 # - past month -> balance as of end of that month (sum of rows
1889 # with created_at <= period_end)
1890 my $cl_where = $is_current
1891 ? ''
1892 : "WHERE created_at <= $period_end_expr";
1893 $r = $db->db_readwrite($dbh, qq~
1894 SELECT COALESCE(SUM(amount_cents),0) AS n
1895 FROM `${DB}`.credit_ledger
1896 $cl_where
1897 ~, $ENV{SCRIPT_NAME}, __LINE__);
1898 $out{outstanding_credit_cents} = ($r && defined $r->{n}) ? $r->{n} : 0;
1899
1900 # Subscription counts by status.
1901 foreach my $st (qw(active trialing past_due)) {
1902 my $col = "${st}_subs"; $col =~ s/^trialing_subs$/trialing_subs/;
1903 my $r2 = $db->db_readwrite($dbh, qq~
1904 SELECT COUNT(*) AS n FROM `${DB}`.subscriptions WHERE status='$st'
1905 ~, $ENV{SCRIPT_NAME}, __LINE__);
1906 $out{$col} = ($r2 && $r2->{n}) ? $r2->{n} : 0;
1907 }
1908 $r = $db->db_readwrite($dbh, qq~
1909 SELECT COUNT(*) AS n FROM `${DB}`.subscriptions
1910 WHERE status='canceled'
1911 AND canceled_at >= DATE_SUB(NOW(), INTERVAL 30 DAY)
1912 ~, $ENV{SCRIPT_NAME}, __LINE__);
1913 $out{canceled_subs_30d} = ($r && $r->{n}) ? $r->{n} : 0;
1914
1915 # MRR: monthly-cadence active/trialing subs at their plan's monthly
1916 # price + 1/12th of any annual-cadence active subs (annual price
1917 # comes from the plan's yearly_* fields, resolved by the same
1918 # rules compute_yearly_price_cents() uses).
1919 # Cadence now lives on the subscription itself, not the plan
1920 # (we collapsed the duplicate monthly/annual plan rows down to
1921 # one row per tier).
1922 $r = $db->db_readwrite($dbh, qq~
1923 SELECT COALESCE(SUM(p.price_cents),0) AS n
1924 FROM `${DB}`.subscriptions s
1925 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1926 WHERE s.status IN ('active','trialing','past_due')
1927 AND s.cadence='monthly'
1928 ~, $ENV{SCRIPT_NAME}, __LINE__);
1929 my $mrr_monthly = ($r && $r->{n}) ? $r->{n} : 0;
1930
1931 $r = $db->db_readwrite($dbh, qq~
1932 SELECT COALESCE(SUM(
1933 CASE p.yearly_mode
1934 WHEN 'explicit' THEN p.yearly_price_cents
1935 WHEN 'percent_off' THEN ROUND(p.price_cents * 12 * (100 - p.yearly_pct_off) / 100)
1936 WHEN 'dollars_off' THEN GREATEST(p.price_cents * 12 - p.yearly_off_cents, 0)
1937 ELSE 0
1938 END
1939 ), 0) AS n
1940 FROM `${DB}`.subscriptions s
1941 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1942 WHERE s.status IN ('active','trialing','past_due')
1943 AND s.cadence='annual'
1944 ~, $ENV{SCRIPT_NAME}, __LINE__);
1945 my $arr_annual = ($r && $r->{n}) ? $r->{n} : 0;
1946
1947 $out{mrr_cents} = $mrr_monthly + int($arr_annual / 12);
1948 $out{arr_cents} = $out{mrr_cents} * 12;
1949
1950 # Subscription invoices we *expect* to issue between now and the end
1951 # of the current calendar month. Used by the admin Projected
1952 # Earnings tile to add scheduled renewals on top of the linear
1953 # pace-only projection. Only meaningful for the current month -- for
1954 # past months the actual cash already landed, so there's nothing to
1955 # project.
1956 if ($is_current) {
1957 $r = $db->db_readwrite($dbh, qq~
1958 SELECT COALESCE(SUM(p.price_cents),0) AS n
1959 FROM `${DB}`.subscriptions s
1960 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1961 WHERE s.status IN ('active','trialing','past_due')
1962 AND s.next_invoice_at IS NOT NULL
1963 AND s.next_invoice_at > NOW()
1964 AND s.next_invoice_at <= LAST_DAY(CURDATE()) + INTERVAL 1 DAY
1965 ~, $ENV{SCRIPT_NAME}, __LINE__);
1966 $out{expected_subs_remaining_cents} = ($r && $r->{n}) ? $r->{n} : 0;
1967 } else {
1968 $out{expected_subs_remaining_cents} = 0;
1969 }
1970
1971 # Plan distribution (count per tier).
1972 my @pb = $db->db_readwrite_multiple($dbh, qq~
1973 SELECT p.slug AS tier, COUNT(*) AS n
1974 FROM `${DB}`.subscriptions s
1975 JOIN `${DB}`.billing_plans p ON p.id = s.plan_id
1976 WHERE s.status IN ('active','trialing','past_due')
1977 GROUP BY p.slug
1978 ORDER BY p.slug ASC
1979 ~, $ENV{SCRIPT_NAME}, __LINE__);
1980 $out{plan_breakdown} = \@pb;
1981
1982 return \%out;
1983}
1984
1985# ---- Signups (free vs paid) ------------------------------------------
1986# "Paid" means current plan_tier is anything other than 'free' -- a
1987# decent proxy for "did this signup convert". A user who upgrades to
1988# paid later will retroactively count as a paid signup; we accept that
1989# trade-off here so we don't have to join the subscription history for
1990# every datapoint. created_at is the signup timestamp.
1991#
1992# Both daily and monthly variants return per-tier counts so the admin
1993# UI can hover-tooltip and click-modal them without an extra round trip.
1994#
1995# admin_signups_daily(days) -> arrayref of
1996# { date, pro, business, trialing, paid, total }
1997# for the trailing N days (default 30), oldest first.
1998#
1999# Post pricing-v3: every signup starts on a 14-day trial pinned to
2000# users.plan_tier (pro|business). `trialing` counts users whose
2001# trial_ends_at is still in the future on the signup date. `paid`
2002# is pro + business (the whole set, since there's no free tier).
2003sub admin_signups_daily {
2004 my ($self, $db, $dbh, $DB, $days) = @_;
2005 return [] unless $self->schema_ready($db, $dbh, $DB);
2006 $days ||= 30; $days =~ s/[^0-9]//g; $days = 30 unless $days;
2007 $days = 365 if $days > 365;
2008
2009 my %by_date;
2010 my @rows = $db->db_readwrite_multiple($dbh, qq~
2011 SELECT DATE(created_at) AS d,
2012 SUM(CASE WHEN plan_tier='pro' THEN 1 ELSE 0 END) AS pro_n,
2013 SUM(CASE WHEN plan_tier='business' THEN 1 ELSE 0 END) AS business_n,
2014 SUM(CASE WHEN trial_ends_at IS NOT NULL
2015 AND trial_ends_at > created_at THEN 1 ELSE 0 END) AS trialing_n
2016 FROM `${DB}`.users
2017 WHERE created_at IS NOT NULL
2018 AND created_at >= DATE_SUB(CURDATE(), INTERVAL $days DAY)
2019 GROUP BY DATE(created_at)
2020 ~, $ENV{SCRIPT_NAME}, __LINE__);
2021 foreach my $r (@rows) { $by_date{$r->{d} || ''} = $r; }
2022
2023 my @out;
2024 my $now = time;
2025 for (my $i = $days - 1; $i >= 0; $i--) {
2026 my @t = localtime($now - $i * 86400);
2027 my $ymd = sprintf('%04d-%02d-%02d', $t[5]+1900, $t[4]+1, $t[3]);
2028 my $r = $by_date{$ymd} || {};
2029 my $pro = ($r->{pro_n} || 0) + 0;
2030 my $business = ($r->{business_n} || 0) + 0;
2031 my $trialing = ($r->{trialing_n} || 0) + 0;
2032 my $paid = $pro + $business;
2033 push @out, {
2034 date => $ymd,
2035 pro => $pro,
2036 business => $business,
2037 trialing => $trialing,
2038 paid => $paid,
2039 total => $paid,
2040 };
2041 }
2042 return \@out;
2043}
2044
2045# admin_signups_monthly(months) -> arrayref of
2046# { month, pro, business, trialing, paid, total }
2047# for the trailing N months (default 12), oldest first. month is YYYY-MM.
2048sub admin_signups_monthly {
2049 my ($self, $db, $dbh, $DB, $months) = @_;
2050 return [] unless $self->schema_ready($db, $dbh, $DB);
2051 $months ||= 12; $months =~ s/[^0-9]//g; $months = 12 unless $months;
2052 $months = 60 if $months > 60;
2053
2054 my %by_month;
2055 my @rows = $db->db_readwrite_multiple($dbh, qq~
2056 SELECT DATE_FORMAT(created_at, '%Y-%m') AS m,
2057 SUM(CASE WHEN plan_tier='pro' THEN 1 ELSE 0 END) AS pro_n,
2058 SUM(CASE WHEN plan_tier='business' THEN 1 ELSE 0 END) AS business_n,
2059 SUM(CASE WHEN trial_ends_at IS NOT NULL
2060 AND trial_ends_at > created_at THEN 1 ELSE 0 END) AS trialing_n
2061 FROM `${DB}`.users
2062 WHERE created_at IS NOT NULL
2063 AND created_at >= DATE_SUB(DATE_FORMAT(CURDATE(),'%Y-%m-01'), INTERVAL ($months - 1) MONTH)
2064 GROUP BY DATE_FORMAT(created_at, '%Y-%m')
2065 ~, $ENV{SCRIPT_NAME}, __LINE__);
2066 foreach my $r (@rows) { $by_month{$r->{m} || ''} = $r; }
2067
2068 my @t = localtime(time);
2069 my $y = $t[5] + 1900;
2070 my $m = $t[4] + 1;
2071 my @out;
2072 for (my $i = $months - 1; $i >= 0; $i--) {
2073 my $back_m = $m - $i;
2074 my $back_y = $y;
2075 while ($back_m <= 0) { $back_m += 12; $back_y -= 1; }
2076 my $ym = sprintf('%04d-%02d', $back_y, $back_m);
2077 my $r = $by_month{$ym} || {};
2078 my $pro = ($r->{pro_n} || 0) + 0;
2079 my $business = ($r->{business_n} || 0) + 0;
2080 my $trialing = ($r->{trialing_n} || 0) + 0;
2081 my $paid = $pro + $business;
2082 push @out, {
2083 month => $ym,
2084 pro => $pro,
2085 business => $business,
2086 trialing => $trialing,
2087 paid => $paid,
2088 total => $paid,
2089 };
2090 }
2091 return \@out;
2092}
2093
2094# Recent invoices across every user (admin page).
2095sub admin_recent_invoices {
2096 my ($self, $db, $dbh, $DB, $limit) = @_;
2097 return () unless $self->schema_ready($db, $dbh, $DB);
2098 $limit ||= 25;
2099 $limit =~ s/[^0-9]//g;
2100 $limit = 25 unless $limit;
2101 $limit = 200 if $limit > 200;
2102
2103 return $db->db_readwrite_multiple($dbh, qq~
2104 SELECT i.id, i.invoice_number, i.user_id,
2105 i.amount_due_cents, i.credit_applied_cents, i.cash_paid_cents,
2106 i.currency, i.status, i.issued_at, i.paid_at, i.created_at,
2107 u.email, u.display_name
2108 FROM `${DB}`.invoices i
2109 LEFT JOIN `${DB}`.users u ON u.id = i.user_id
2110 ORDER BY COALESCE(i.issued_at, i.created_at) DESC, i.id DESC
2111 LIMIT $limit
2112 ~, $ENV{SCRIPT_NAME}, __LINE__);
2113}
2114
2115# Accounts with a non-zero credit balance. Used on the admin page so
2116# staff can see who has outstanding credit at a glance.
2117sub admin_credit_holders {
2118 my ($self, $db, $dbh, $DB, $limit) = @_;
2119 return () unless $self->schema_ready($db, $dbh, $DB);
2120 $limit ||= 25;
2121 $limit =~ s/[^0-9]//g;
2122 $limit = 25 unless $limit;
2123 $limit = 200 if $limit > 200;
2124
2125 return $db->db_readwrite_multiple($dbh, qq~
2126 SELECT u.id AS user_id, u.email, u.display_name,
2127 COALESCE(SUM(cl.amount_cents),0) AS balance_cents
2128 FROM `${DB}`.users u
2129 JOIN `${DB}`.credit_ledger cl ON cl.user_id = u.id
2130 GROUP BY u.id
2131 HAVING balance_cents <> 0
2132 ORDER BY balance_cents DESC
2133 LIMIT $limit
2134 ~, $ENV{SCRIPT_NAME}, __LINE__);
2135}
2136
2137# ---- Formatting helpers ---------------------------------------------
2138sub fmt_money {
2139 my ($self, $cents, $currency) = @_;
2140 $currency ||= 'USD';
2141 $cents = 0 unless defined $cents;
2142 my $sign = ($cents < 0) ? '-' : '';
2143 my $abs = abs($cents);
2144 my $dollars = sprintf('%.2f', $abs / 100);
2145 # Insert thousands separators into the dollar portion.
2146 my ($whole, $frac) = split('\.', $dollars);
2147 1 while $whole =~ s/(\d)(\d{3})(?!\d)/$1,$2/;
2148 return $sign . '$' . $whole . '.' . $frac;
2149}
2150
2151sub fmt_cadence {
2152 my ($self, $cadence) = @_;
2153 return 'monthly' unless $cadence;
2154 return $cadence eq 'annual' ? 'year' : 'month';
2155}
2156
2157# ---- Admin Packages CRUD --------------------------------------------
2158# Used by admin_packages.cgi / admin_packages_action.cgi. None of these
2159# touch entitlements directly -- callers set_plan_features after a
2160# successful create/update.
2161sub _esc_sql {
2162 my $s = shift; $s = '' unless defined $s;
2163 $s =~ s/\\/\\\\/g; $s =~ s/'/''/g; return $s;
2164}
2165
2166# Create a new billing_plans row. Returns the new row id on success
2167# or (0, $error_message) on failure.
2168sub create_plan {
2169 my ($self, $db, $dbh, $DB, %a) = @_;
2170 return (0, 'billing schema not migrated') unless $self->schema_ready($db, $dbh, $DB);
2171 return (0, 'plan columns not migrated') unless $self->plan_columns_ready($db, $dbh, $DB);
2172
2173 my $tier = lc(_esc_sql($a{tier} || '')); $tier =~ s/[^a-z0-9_\-]//g;
2174 my $cadence = lc(_esc_sql($a{cadence} || 'monthly'));
2175 my $display_name = _esc_sql($a{display_name} || '');
2176 my $tagline = _esc_sql($a{tagline} || '');
2177 my $cta_label = _esc_sql($a{cta_label} || '');
2178 my $features_raw = _esc_sql($a{features} || '');
2179 my $currency = uc(_esc_sql($a{currency} || 'USD')); $currency = substr($currency,0,3);
2180 my $price = $a{price_cents}; $price =~ s/[^0-9]//g; $price = 0 unless $price;
2181 my $sort_order = $a{sort_order}; $sort_order =~ s/[^0-9-]//g; $sort_order = 0 unless length $sort_order;
2182 my $is_featured = $a{is_featured} ? 1 : 0;
2183 my $is_active = (defined $a{is_active} ? $a{is_active} : 1) ? 1 : 0;
2184
2185 return (0, 'cadence must be monthly or annual')
2186 unless $cadence eq 'monthly' || $cadence eq 'annual';
2187 return (0, 'tier is required') unless $tier;
2188 return (0, 'display name is required') unless length $display_name;
2189
2190 # Block duplicate slug. DB has a UNIQUE KEY on slug but we want a
2191 # friendlier error message than the driver default. (Live schema is
2192 # one row per tier; the cadence param is kept for back-compat with
2193 # the admin form but billing_period is set from $cadence.)
2194 my $dup = $db->db_readwrite($dbh, qq~
2195 SELECT id FROM `${DB}`.billing_plans
2196 WHERE slug='$tier' LIMIT 1
2197 ~, $ENV{SCRIPT_NAME}, __LINE__);
2198 return (0, "A plan with slug '$tier' already exists.")
2199 if $dup && $dup->{id};
2200
2201 # Yearly price is stored explicitly on the row (0 = annual not
2202 # offered). The legacy percent_off / dollars_off modes have been
2203 # removed in favor of a single explicit cents field.
2204 my $yprc = defined $a{yearly_price_cents} ? int($a{yearly_price_cents} || 0) : 0;
2205
2206 my $r = $db->db_readwrite($dbh, qq~
2207 INSERT INTO `${DB}`.billing_plans
2208 SET slug='$tier',
2209 billing_period='$cadence',
2210 name='$display_name',
2211 tagline='$tagline',
2212 cta_label='$cta_label',
2213 price_cents='$price',
2214 yearly_price_cents='$yprc',
2215 currency='$currency',
2216 features_json='$features_raw',
2217 sort_order='$sort_order',
2218 is_featured='$is_featured',
2219 is_active='$is_active'
2220 ~, $ENV{SCRIPT_NAME}, __LINE__);
2221 my $new_id = ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0;
2222 return ($new_id, '');
2223}
2224
2225# Update an existing plan. $plan_id must exist or this is a no-op.
2226# Same return shape as create_plan: (id, error).
2227sub update_plan {
2228 my ($self, $db, $dbh, $DB, $plan_id, %a) = @_;
2229 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2230 return (0, 'plan id required') unless $plan_id;
2231 return (0, 'billing schema not migrated') unless $self->schema_ready($db, $dbh, $DB);
2232 return (0, 'plan columns not migrated') unless $self->plan_columns_ready($db, $dbh, $DB);
2233
2234 my $existing = $self->plan_by_id($db, $dbh, $DB, $plan_id);
2235 return (0, 'plan not found') unless $existing && $existing->{id};
2236
2237 my $tier = lc(_esc_sql($a{tier} || $existing->{tier}));
2238 $tier =~ s/[^a-z0-9_\-]//g;
2239 my $cadence = lc(_esc_sql($a{cadence} || $existing->{cadence} || 'monthly'));
2240 my $display_name = _esc_sql(defined $a{display_name} ? $a{display_name} : $existing->{display_name});
2241 my $tagline = _esc_sql(defined $a{tagline} ? $a{tagline} : ($existing->{tagline} || ''));
2242 my $cta_label = _esc_sql(defined $a{cta_label} ? $a{cta_label} : ($existing->{cta_label} || ''));
2243 my $features_raw = _esc_sql(defined $a{features} ? $a{features} : ($existing->{features} || ''));
2244 my $currency = uc(_esc_sql($a{currency} || $existing->{currency} || 'USD'));
2245 $currency = substr($currency,0,3);
2246 my $price = defined $a{price_cents} ? $a{price_cents} : ($existing->{price_cents} || 0);
2247 $price =~ s/[^0-9]//g; $price = 0 unless $price;
2248 my $sort_order = defined $a{sort_order} ? $a{sort_order} : ($existing->{sort_order} || 0);
2249 $sort_order =~ s/[^0-9-]//g; $sort_order = 0 unless length $sort_order;
2250 my $is_featured = $a{is_featured} ? 1 : 0;
2251 my $is_active = (defined $a{is_active} ? $a{is_active} : 1) ? 1 : 0;
2252
2253 return (0, 'cadence must be monthly or annual')
2254 unless $cadence eq 'monthly' || $cadence eq 'annual';
2255 return (0, 'tier is required') unless $tier;
2256 return (0, 'display name is required') unless length $display_name;
2257
2258 # Guard the unique key when slug changes.
2259 if ($tier ne $existing->{tier}) {
2260 my $dup = $db->db_readwrite($dbh, qq~
2261 SELECT id FROM `${DB}`.billing_plans
2262 WHERE slug='$tier' AND id<>'$plan_id'
2263 LIMIT 1
2264 ~, $ENV{SCRIPT_NAME}, __LINE__);
2265 return (0, "A plan with slug '$tier' already exists.")
2266 if $dup && $dup->{id};
2267 }
2268
2269 # Yearly price stored explicitly. If caller didn't pass it, keep the
2270 # existing value (so old code paths that only edit name/price don't
2271 # wipe the plan's yearly config).
2272 my $yprc = defined $a{yearly_price_cents} ? int($a{yearly_price_cents} || 0) : int($existing->{yearly_price_cents} || 0);
2273
2274 $db->db_readwrite($dbh, qq~
2275 UPDATE `${DB}`.billing_plans
2276 SET slug='$tier',
2277 billing_period='$cadence',
2278 name='$display_name',
2279 tagline='$tagline',
2280 cta_label='$cta_label',
2281 price_cents='$price',
2282 yearly_price_cents='$yprc',
2283 currency='$currency',
2284 features_json='$features_raw',
2285 sort_order='$sort_order',
2286 is_featured='$is_featured',
2287 is_active='$is_active'
2288 WHERE id='$plan_id'
2289 ~, $ENV{SCRIPT_NAME}, __LINE__);
2290 return ($plan_id, '');
2291}
2292
2293# Soft-delete (deactivate) a plan. We don't hard-delete because
2294# subscriptions FK ON DELETE RESTRICT and historical rows must keep
2295# the price/tier label intact.
2296sub deactivate_plan {
2297 my ($self, $db, $dbh, $DB, $plan_id) = @_;
2298 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2299 return 0 unless $plan_id;
2300 return 0 unless $self->schema_ready($db, $dbh, $DB);
2301 $db->db_readwrite($dbh, qq~
2302 UPDATE `${DB}`.billing_plans SET is_active=0 WHERE id='$plan_id'
2303 ~, $ENV{SCRIPT_NAME}, __LINE__);
2304 return 1;
2305}
2306
2307sub activate_plan {
2308 my ($self, $db, $dbh, $DB, $plan_id) = @_;
2309 $plan_id =~ s/[^0-9]//g if defined $plan_id;
2310 return 0 unless $plan_id;
2311 return 0 unless $self->schema_ready($db, $dbh, $DB);
2312 $db->db_readwrite($dbh, qq~
2313 UPDATE `${DB}`.billing_plans SET is_active=1 WHERE id='$plan_id'
2314 ~, $ENV{SCRIPT_NAME}, __LINE__);
2315 return 1;
2316}
2317
23181;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help