added on local at 2026-07-01 22:09:40
| 1 | package MODS::ShopCart::Subscriptions; | |
| 2 | #====================================================================== | |
| 3 | # ShopCart -- subscription plan + buyer-subscription helpers. | |
| 4 | # | |
| 5 | # Two flavors per plan: | |
| 6 | # download_quota -- buyer gets N downloads / cadence from a pool | |
| 7 | # ship_monthly -- seller ships N items / cadence | |
| 8 | # | |
| 9 | # Pool resolution: | |
| 10 | # 'all' -- every published model on this storefront | |
| 11 | # 'category' -- one seller_categories row | |
| 12 | # 'specific' -- explicit list (subscription_plan_models) | |
| 13 | # | |
| 14 | # Public surface (most things take ($db,$dbh,$DB)): | |
| 15 | # schema_ready | |
| 16 | # plans_for_user, plan_by_id, create_plan, update_plan, set_plan_models | |
| 17 | # buyer_subscriptions_for, can_download_model, record_download, | |
| 18 | # period_remaining | |
| 19 | #====================================================================== | |
| 20 | use strict; | |
| 21 | use warnings; | |
| 22 | ||
| 23 | sub new { bless {}, shift } | |
| 24 | ||
| 25 | sub _esc { my $s = shift // ''; $s =~ s/\\/\\\\/g; $s =~ s/'/''/g; return $s; } | |
| 26 | sub _slugify { | |
| 27 | my ($s) = @_; return '' unless defined $s; | |
| 28 | $s = lc $s; $s =~ s/[^a-z0-9]+/-/g; $s =~ s/^-+|-+$//g; | |
| 29 | return substr($s, 0, 80); | |
| 30 | } | |
| 31 | ||
| 32 | sub schema_ready { | |
| 33 | my ($self, $db, $dbh, $DB) = @_; | |
| 34 | return $self->{_ready} if exists $self->{_ready}; | |
| 35 | foreach my $t (qw(subscription_plans subscription_plan_models buyer_subscriptions subscription_downloads subscription_shipments)) { | |
| 36 | my $r = $db->db_readwrite($dbh, qq~ | |
| 37 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 38 | WHERE table_schema='$DB' AND table_name='$t' | |
| 39 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 40 | unless ($r && $r->{n}) { $self->{_ready} = 0; return 0; } | |
| 41 | } | |
| 42 | $self->{_ready} = 1; | |
| 43 | return 1; | |
| 44 | } | |
| 45 | ||
| 46 | # ---- Seller side ---------------------------------------------------- | |
| 47 | ||
| 48 | sub plans_for_user { | |
| 49 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 50 | return [] unless $uid && $self->schema_ready($db, $dbh, $DB); | |
| 51 | $uid =~ s/[^0-9]//g; return [] unless length $uid; | |
| 52 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 53 | SELECT sp.*, ( | |
| 54 | SELECT COUNT(*) FROM `${DB}`.buyer_subscriptions bs | |
| 55 | WHERE bs.plan_id=sp.id AND bs.status='active' | |
| 56 | ) AS active_subs | |
| 57 | FROM `${DB}`.subscription_plans sp | |
| 58 | WHERE sp.user_id='$uid' | |
| 59 | ORDER BY sp.created_at DESC, sp.id DESC | |
| 60 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 61 | return \@rows; | |
| 62 | } | |
| 63 | ||
| 64 | sub plan_by_id { | |
| 65 | my ($self, $db, $dbh, $DB, $id, $uid) = @_; | |
| 66 | return undef unless $id && $self->schema_ready($db, $dbh, $DB); | |
| 67 | $id =~ s/[^0-9]//g; return undef unless length $id; | |
| 68 | my $where = ''; | |
| 69 | if ($uid) { | |
| 70 | $uid =~ s/[^0-9]//g; | |
| 71 | $where = " AND user_id='$uid'" if length $uid; | |
| 72 | } | |
| 73 | my $r = $db->db_readwrite($dbh, qq~ | |
| 74 | SELECT * FROM `${DB}`.subscription_plans WHERE id='$id' $where LIMIT 1 | |
| 75 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 76 | return ($r && $r->{id}) ? $r : undef; | |
| 77 | } | |
| 78 | ||
| 79 | sub _default_storefront { | |
| 80 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 81 | my $r = $db->db_readwrite($dbh, qq~ | |
| 82 | SELECT id FROM `${DB}`.storefronts WHERE user_id='$uid' ORDER BY id ASC LIMIT 1 | |
| 83 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 84 | return ($r && $r->{id}) ? $r->{id} : 0; | |
| 85 | } | |
| 86 | ||
| 87 | sub create_plan { | |
| 88 | my ($self, $db, $dbh, $DB, $uid, %f) = @_; | |
| 89 | return 0 unless $uid && $self->schema_ready($db, $dbh, $DB); | |
| 90 | $uid =~ s/[^0-9]//g; return 0 unless length $uid; | |
| 91 | my $name = substr($f{name} || '', 0, 160); | |
| 92 | return 0 unless length $name; | |
| 93 | my $slug = _slugify($f{slug} || $name) || ('plan-' . time()); | |
| 94 | my $sid = $f{storefront_id} || $self->_default_storefront($db, $dbh, $DB, $uid); | |
| 95 | return 0 unless $sid; | |
| 96 | my $kind = lc($f{kind} || 'download_quota'); | |
| 97 | $kind = 'download_quota' unless $kind =~ /^(download_quota|ship_monthly)$/; | |
| 98 | my $price_cents = int(($f{price} || 0) * 100); | |
| 99 | return 0 unless $price_cents > 0; | |
| 100 | my $cadence = int($f{cadence_days} || 30); $cadence = 30 if $cadence < 1; | |
| 101 | my $quota = int($f{quota_per_period} || 1); $quota = 1 if $quota < 1; | |
| 102 | my $pool_kind = lc($f{pool_kind} || 'all'); | |
| 103 | $pool_kind = 'all' unless $pool_kind =~ /^(all|category|specific)$/; | |
| 104 | my $cat_id = ''; | |
| 105 | if ($pool_kind eq 'category') { | |
| 106 | $cat_id = $f{pool_category_id} || ''; $cat_id =~ s/[^0-9]//g; | |
| 107 | } | |
| 108 | my $cat_sql = length $cat_id ? "'$cat_id'" : 'NULL'; | |
| 109 | my $maxs = int($f{max_subscribers} || 0); $maxs = 0 if $maxs < 0; | |
| 110 | my $tag = substr($f{tagline} || '', 0, 255); | |
| 111 | my $desc = substr($f{description} || '', 0, 65535); | |
| 112 | ||
| 113 | # Slug must be unique per seller. | |
| 114 | my $check = $db->db_readwrite($dbh, qq~ | |
| 115 | SELECT id FROM `${DB}`.subscription_plans | |
| 116 | WHERE user_id='$uid' AND slug='~ . _esc($slug) . qq~' LIMIT 1 | |
| 117 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 118 | return 0 if $check && $check->{id}; | |
| 119 | ||
| 120 | $db->db_readwrite($dbh, qq~ | |
| 121 | INSERT INTO `${DB}`.subscription_plans SET | |
| 122 | user_id='$uid', storefront_id='$sid', | |
| 123 | slug='~ . _esc($slug) . qq~', | |
| 124 | name='~ . _esc($name) . qq~', | |
| 125 | tagline='~ . _esc($tag) . qq~', | |
| 126 | description='~ . _esc($desc) . qq~', | |
| 127 | kind='$kind', | |
| 128 | price_cents='$price_cents', | |
| 129 | cadence_days='$cadence', | |
| 130 | quota_per_period='$quota', | |
| 131 | pool_kind='$pool_kind', | |
| 132 | pool_category_id=$cat_sql, | |
| 133 | max_subscribers='$maxs', | |
| 134 | status='draft', | |
| 135 | created_at=NOW() | |
| 136 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 137 | my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 138 | return ($r && $r->{id}) ? $r->{id} : 0; | |
| 139 | } | |
| 140 | ||
| 141 | sub update_plan { | |
| 142 | my ($self, $db, $dbh, $DB, $id, $uid, %f) = @_; | |
| 143 | return 0 unless $self->plan_by_id($db, $dbh, $DB, $id, $uid); | |
| 144 | $id =~ s/[^0-9]//g; $uid =~ s/[^0-9]//g; | |
| 145 | my @sets; | |
| 146 | if (defined $f{name}) { push @sets, "name='" . _esc(substr($f{name},0,160)) . "'"; } | |
| 147 | if (defined $f{tagline}) { push @sets, "tagline='" . _esc(substr($f{tagline},0,255)) . "'"; } | |
| 148 | if (defined $f{description}) { push @sets, "description='" . _esc(substr($f{description},0,65535)) . "'"; } | |
| 149 | if (defined $f{kind}) { | |
| 150 | my $k = lc($f{kind}); $k = 'download_quota' unless $k =~ /^(download_quota|ship_monthly)$/; | |
| 151 | push @sets, "kind='$k'"; | |
| 152 | } | |
| 153 | if (defined $f{price}) { push @sets, "price_cents='" . int($f{price} * 100) . "'"; } | |
| 154 | if (defined $f{cadence_days}) { push @sets, "cadence_days='" . int($f{cadence_days}) . "'"; } | |
| 155 | if (defined $f{quota_per_period}) { push @sets, "quota_per_period='" . int($f{quota_per_period}) . "'"; } | |
| 156 | if (defined $f{pool_kind}) { | |
| 157 | my $pk = lc($f{pool_kind}); $pk = 'all' unless $pk =~ /^(all|category|specific)$/; | |
| 158 | push @sets, "pool_kind='$pk'"; | |
| 159 | if ($pk eq 'category') { | |
| 160 | my $c = $f{pool_category_id} || ''; $c =~ s/[^0-9]//g; | |
| 161 | push @sets, "pool_category_id=" . (length $c ? "'$c'" : 'NULL'); | |
| 162 | } else { | |
| 163 | push @sets, "pool_category_id=NULL"; | |
| 164 | } | |
| 165 | } | |
| 166 | if (defined $f{max_subscribers}) { push @sets, "max_subscribers='" . int($f{max_subscribers}) . "'"; } | |
| 167 | if (defined $f{status}) { | |
| 168 | my $s = lc($f{status}); $s = 'draft' unless $s =~ /^(draft|active|paused|archived)$/; | |
| 169 | push @sets, "status='$s'"; | |
| 170 | } | |
| 171 | return 1 unless @sets; | |
| 172 | $db->db_readwrite($dbh, qq~ | |
| 173 | UPDATE `${DB}`.subscription_plans SET ~ . join(',', @sets) . qq~ | |
| 174 | WHERE id='$id' AND user_id='$uid' LIMIT 1 | |
| 175 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 176 | return 1; | |
| 177 | } | |
| 178 | ||
| 179 | sub set_plan_models { | |
| 180 | my ($self, $db, $dbh, $DB, $plan_id, $model_ids, $uid) = @_; | |
| 181 | return 0 unless $self->plan_by_id($db, $dbh, $DB, $plan_id, $uid); | |
| 182 | $plan_id =~ s/[^0-9]//g; $uid =~ s/[^0-9]//g; | |
| 183 | $db->db_readwrite($dbh, qq~ | |
| 184 | DELETE FROM `${DB}`.subscription_plan_models WHERE plan_id='$plan_id' | |
| 185 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 186 | my $sort = 0; | |
| 187 | foreach my $mid (@{ $model_ids || [] }) { | |
| 188 | $mid =~ s/[^0-9]//g; next unless length $mid; | |
| 189 | my $own = $db->db_readwrite($dbh, qq~ | |
| 190 | SELECT id FROM `${DB}`.models WHERE id='$mid' AND user_id='$uid' AND purged_at IS NULL LIMIT 1 | |
| 191 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 192 | next unless $own && $own->{id}; | |
| 193 | $db->db_readwrite($dbh, qq~ | |
| 194 | INSERT IGNORE INTO `${DB}`.subscription_plan_models SET | |
| 195 | plan_id='$plan_id', model_id='$mid', | |
| 196 | sort_order='$sort', added_at=NOW() | |
| 197 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 198 | $sort++; | |
| 199 | } | |
| 200 | return 1; | |
| 201 | } | |
| 202 | ||
| 203 | sub plan_models { | |
| 204 | my ($self, $db, $dbh, $DB, $plan_id) = @_; | |
| 205 | return [] unless $plan_id && $self->schema_ready($db, $dbh, $DB); | |
| 206 | $plan_id =~ s/[^0-9]//g; | |
| 207 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 208 | SELECT spm.model_id, m.title, m.base_price_cents, m.product_kind | |
| 209 | FROM `${DB}`.subscription_plan_models spm | |
| 210 | JOIN `${DB}`.models m ON m.id = spm.model_id | |
| 211 | WHERE spm.plan_id='$plan_id' AND m.purged_at IS NULL | |
| 212 | ORDER BY spm.sort_order ASC | |
| 213 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 214 | return \@rows; | |
| 215 | } | |
| 216 | ||
| 217 | # Public plan list for a storefront (buyer-side). | |
| 218 | sub active_plans_for_storefront { | |
| 219 | my ($self, $db, $dbh, $DB, $sid) = @_; | |
| 220 | return [] unless $sid && $self->schema_ready($db, $dbh, $DB); | |
| 221 | $sid =~ s/[^0-9]//g; return [] unless length $sid; | |
| 222 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 223 | SELECT * FROM `${DB}`.subscription_plans | |
| 224 | WHERE storefront_id='$sid' AND status='active' | |
| 225 | ORDER BY price_cents ASC, id ASC | |
| 226 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 227 | return \@rows; | |
| 228 | } | |
| 229 | ||
| 230 | # ---- Buyer side ----------------------------------------------------- | |
| 231 | ||
| 232 | sub buyer_subscriptions_for { | |
| 233 | my ($self, $db, $dbh, $DB, $buyer_id) = @_; | |
| 234 | return [] unless $buyer_id && $self->schema_ready($db, $dbh, $DB); | |
| 235 | $buyer_id =~ s/[^0-9]//g; return [] unless length $buyer_id; | |
| 236 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 237 | SELECT bs.*, sp.name AS plan_name, sp.kind AS plan_kind, | |
| 238 | sp.quota_per_period, sp.cadence_days, sp.price_cents, | |
| 239 | sp.pool_kind, sp.pool_category_id, sp.user_id AS seller_id | |
| 240 | FROM `${DB}`.buyer_subscriptions bs | |
| 241 | JOIN `${DB}`.subscription_plans sp ON sp.id = bs.plan_id | |
| 242 | WHERE bs.buyer_account_id='$buyer_id' | |
| 243 | ORDER BY bs.status='active' DESC, bs.created_at DESC | |
| 244 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 245 | return \@rows; | |
| 246 | } | |
| 247 | ||
| 248 | # Does the active subscription give this buyer free access to download | |
| 249 | # the given model right now? Returns the buyer_subscription row + remaining | |
| 250 | # quota when yes; undef when no. | |
| 251 | sub can_download_model { | |
| 252 | my ($self, $db, $dbh, $DB, $buyer_id, $model_id) = @_; | |
| 253 | return undef unless $buyer_id && $model_id && $self->schema_ready($db, $dbh, $DB); | |
| 254 | $buyer_id =~ s/[^0-9]//g; $model_id =~ s/[^0-9]//g; | |
| 255 | return undef unless length $buyer_id && length $model_id; | |
| 256 | ||
| 257 | # Look up the model's seller -- only same-seller subscriptions count. | |
| 258 | my $m = $db->db_readwrite($dbh, qq~ | |
| 259 | SELECT user_id FROM `${DB}`.models WHERE id='$model_id' LIMIT 1 | |
| 260 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 261 | return undef unless $m && $m->{user_id}; | |
| 262 | my $seller = $m->{user_id}; | |
| 263 | ||
| 264 | # Active subs from this seller, kind=download_quota. | |
| 265 | my @subs = $db->db_readwrite_multiple($dbh, qq~ | |
| 266 | SELECT bs.id, bs.current_period_end, bs.downloads_used_this_period, | |
| 267 | sp.id AS plan_id, sp.kind, sp.quota_per_period, | |
| 268 | sp.pool_kind, sp.pool_category_id | |
| 269 | FROM `${DB}`.buyer_subscriptions bs | |
| 270 | JOIN `${DB}`.subscription_plans sp ON sp.id = bs.plan_id | |
| 271 | WHERE bs.buyer_account_id='$buyer_id' | |
| 272 | AND bs.status='active' | |
| 273 | AND sp.user_id='$seller' | |
| 274 | AND sp.kind='download_quota' | |
| 275 | AND (bs.current_period_end IS NULL OR bs.current_period_end > NOW()) | |
| 276 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 277 | foreach my $s (@subs) { | |
| 278 | # Quota left? | |
| 279 | my $used = $s->{downloads_used_this_period} || 0; | |
| 280 | my $qty = $s->{quota_per_period} || 0; | |
| 281 | next if $qty && $used >= $qty; | |
| 282 | # Pool match? | |
| 283 | my $match = 0; | |
| 284 | if ($s->{pool_kind} eq 'all') { | |
| 285 | $match = 1; | |
| 286 | } elsif ($s->{pool_kind} eq 'category') { | |
| 287 | my $cid = $s->{pool_category_id}; $cid =~ s/[^0-9]//g; | |
| 288 | if (length $cid) { | |
| 289 | my $hit = $db->db_readwrite($dbh, qq~ | |
| 290 | SELECT 1 AS hit FROM `${DB}`.model_seller_categories | |
| 291 | WHERE model_id='$model_id' AND category_id='$cid' LIMIT 1 | |
| 292 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 293 | $match = 1 if $hit && $hit->{hit}; | |
| 294 | } | |
| 295 | } elsif ($s->{pool_kind} eq 'specific') { | |
| 296 | my $hit = $db->db_readwrite($dbh, qq~ | |
| 297 | SELECT 1 AS hit FROM `${DB}`.subscription_plan_models | |
| 298 | WHERE plan_id='$s->{plan_id}' AND model_id='$model_id' LIMIT 1 | |
| 299 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 300 | $match = 1 if $hit && $hit->{hit}; | |
| 301 | } | |
| 302 | return { %$s, remaining => ($qty - $used) } if $match; | |
| 303 | } | |
| 304 | return undef; | |
| 305 | } | |
| 306 | ||
| 307 | sub record_download { | |
| 308 | my ($self, $db, $dbh, $DB, $buyer_sub_id, $model_id) = @_; | |
| 309 | return 0 unless $buyer_sub_id && $model_id && $self->schema_ready($db, $dbh, $DB); | |
| 310 | $buyer_sub_id =~ s/[^0-9]//g; $model_id =~ s/[^0-9]//g; | |
| 311 | return 0 unless length $buyer_sub_id && length $model_id; | |
| 312 | ||
| 313 | # Read the current period start so the row is anchored even if the | |
| 314 | # worker rolls over a microsecond later. | |
| 315 | my $sub = $db->db_readwrite($dbh, qq~ | |
| 316 | SELECT current_period_start FROM `${DB}`.buyer_subscriptions | |
| 317 | WHERE id='$buyer_sub_id' LIMIT 1 | |
| 318 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 319 | return 0 unless $sub; | |
| 320 | my $ps = $sub->{current_period_start}; | |
| 321 | my $ps_sql = $ps ? "'$ps'" : 'NULL'; | |
| 322 | ||
| 323 | $db->db_readwrite($dbh, qq~ | |
| 324 | INSERT INTO `${DB}`.subscription_downloads SET | |
| 325 | buyer_sub_id='$buyer_sub_id', | |
| 326 | model_id='$model_id', | |
| 327 | period_start=$ps_sql, | |
| 328 | downloaded_at=NOW() | |
| 329 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 330 | $db->db_readwrite($dbh, qq~ | |
| 331 | UPDATE `${DB}`.buyer_subscriptions | |
| 332 | SET downloads_used_this_period = downloads_used_this_period + 1 | |
| 333 | WHERE id='$buyer_sub_id' LIMIT 1 | |
| 334 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 335 | return 1; | |
| 336 | } | |
| 337 | ||
| 338 | # Worker-side: roll over every subscription whose period_end has passed. | |
| 339 | # Resets quota counters, advances current_period_*, queues a shipment | |
| 340 | # row for ship_monthly plans. Caller can run on a daily cron. | |
| 341 | sub roll_periods { | |
| 342 | my ($self, $db, $dbh, $DB) = @_; | |
| 343 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 344 | my @due = $db->db_readwrite_multiple($dbh, qq~ | |
| 345 | SELECT bs.id, bs.plan_id, bs.current_period_end, | |
| 346 | sp.cadence_days, sp.kind | |
| 347 | FROM `${DB}`.buyer_subscriptions bs | |
| 348 | JOIN `${DB}`.subscription_plans sp ON sp.id=bs.plan_id | |
| 349 | WHERE bs.status='active' | |
| 350 | AND (bs.current_period_end IS NULL OR bs.current_period_end <= NOW()) | |
| 351 | LIMIT 500 | |
| 352 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 353 | foreach my $s (@due) { | |
| 354 | my $cad = int($s->{cadence_days} || 30); | |
| 355 | $db->db_readwrite($dbh, qq~ | |
| 356 | UPDATE `${DB}`.buyer_subscriptions | |
| 357 | SET current_period_start = NOW(), | |
| 358 | current_period_end = DATE_ADD(NOW(), INTERVAL $cad DAY), | |
| 359 | downloads_used_this_period = 0, | |
| 360 | shipments_used_this_period = 0 | |
| 361 | WHERE id='$s->{id}' LIMIT 1 | |
| 362 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 363 | if ($s->{kind} eq 'ship_monthly') { | |
| 364 | $db->db_readwrite($dbh, qq~ | |
| 365 | INSERT INTO `${DB}`.subscription_shipments SET | |
| 366 | buyer_sub_id='$s->{id}', | |
| 367 | period_start=NOW(), | |
| 368 | period_end=DATE_ADD(NOW(), INTERVAL $cad DAY), | |
| 369 | status='queued', | |
| 370 | created_at=NOW() | |
| 371 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 372 | } | |
| 373 | } | |
| 374 | return scalar(@due); | |
| 375 | } | |
| 376 | ||
| 377 | # Initialize a brand-new buyer subscription. Caller is responsible | |
| 378 | # for actually charging the buyer (via Stripe Subscription or a | |
| 379 | # one-shot PaymentIntent). Returns the new row id. | |
| 380 | sub start_subscription { | |
| 381 | my ($self, $db, $dbh, $DB, %f) = @_; | |
| 382 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 383 | my $buyer_id = $f{buyer_account_id} || 0; $buyer_id =~ s/[^0-9]//g; | |
| 384 | my $plan_id = $f{plan_id} || 0; $plan_id =~ s/[^0-9]//g; | |
| 385 | return 0 unless $buyer_id && $plan_id; | |
| 386 | ||
| 387 | my $plan = $db->db_readwrite($dbh, qq~ | |
| 388 | SELECT cadence_days FROM `${DB}`.subscription_plans WHERE id='$plan_id' LIMIT 1 | |
| 389 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 390 | return 0 unless $plan; | |
| 391 | my $cad = int($plan->{cadence_days} || 30); | |
| 392 | ||
| 393 | my $stripe_sub = $f{stripe_subscription_id} || ''; | |
| 394 | my $stripe_cust= $f{stripe_customer_id} || ''; | |
| 395 | for ($stripe_sub, $stripe_cust) { s/'/''/g; } | |
| 396 | my $ss_sql = length $stripe_sub ? "'$stripe_sub'" : 'NULL'; | |
| 397 | my $sc_sql = length $stripe_cust ? "'$stripe_cust'" : 'NULL'; | |
| 398 | ||
| 399 | # Ship address snapshot (optional). | |
| 400 | my %sh; | |
| 401 | foreach my $k (qw(ship_name ship_addr1 ship_addr2 ship_city ship_region ship_postal ship_country)) { | |
| 402 | $sh{$k} = $f{$k} || ''; | |
| 403 | $sh{$k} = substr($sh{$k}, 0, 200); $sh{$k} =~ s/'/''/g; | |
| 404 | } | |
| 405 | my @sh_bits = map { "$_='$sh{$_}'" } grep { length $sh{$_} } keys %sh; | |
| 406 | my $sh_set = scalar(@sh_bits) ? ',' . join(',', @sh_bits) : ''; | |
| 407 | ||
| 408 | $db->db_readwrite($dbh, qq~ | |
| 409 | INSERT INTO `${DB}`.buyer_subscriptions SET | |
| 410 | buyer_account_id='$buyer_id', | |
| 411 | plan_id='$plan_id', | |
| 412 | status='active', | |
| 413 | current_period_start=NOW(), | |
| 414 | current_period_end=DATE_ADD(NOW(), INTERVAL $cad DAY), | |
| 415 | stripe_subscription_id=$ss_sql, | |
| 416 | stripe_customer_id=$sc_sql$sh_set, | |
| 417 | started_at=NOW(), | |
| 418 | created_at=NOW() | |
| 419 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 420 | my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 421 | return ($r && $r->{id}) ? $r->{id} : 0; | |
| 422 | } | |
| 423 | ||
| 424 | sub cancel_subscription { | |
| 425 | my ($self, $db, $dbh, $DB, $sub_id, $buyer_id) = @_; | |
| 426 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 427 | $sub_id =~ s/[^0-9]//g; $buyer_id =~ s/[^0-9]//g; | |
| 428 | return 0 unless length $sub_id && length $buyer_id; | |
| 429 | $db->db_readwrite($dbh, qq~ | |
| 430 | UPDATE `${DB}`.buyer_subscriptions | |
| 431 | SET status='canceled', canceled_at=NOW() | |
| 432 | WHERE id='$sub_id' AND buyer_account_id='$buyer_id' LIMIT 1 | |
| 433 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 434 | return 1; | |
| 435 | } | |
| 436 | ||
| 437 | # Lazy-create the Stripe Product + Price for a plan. Idempotent: | |
| 438 | # returns the cached ids on subscription_plans if already set, else | |
| 439 | # calls Stripe and caches. Returns { product => 'prod_...', price => | |
| 440 | # 'price_...' } or { error => '...' }. | |
| 441 | sub ensure_stripe_price { | |
| 442 | my ($self, $db, $dbh, $DB, $plan_id, $stripe) = @_; | |
| 443 | return { error => 'no plan' } unless $plan_id && $stripe; | |
| 444 | $plan_id =~ s/[^0-9]//g; return { error => 'bad plan id' } unless length $plan_id; | |
| 445 | return { error => 'stripe not configured' } unless $stripe->is_configured; | |
| 446 | ||
| 447 | my $plan = $db->db_readwrite($dbh, qq~ | |
| 448 | SELECT id, name, description, price_cents, currency, cadence_days, | |
| 449 | stripe_product_id, stripe_price_id | |
| 450 | FROM `${DB}`.subscription_plans WHERE id='$plan_id' LIMIT 1 | |
| 451 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 452 | return { error => 'plan not found' } unless $plan; | |
| 453 | if ($plan->{stripe_product_id} && $plan->{stripe_price_id}) { | |
| 454 | return { product => $plan->{stripe_product_id}, price => $plan->{stripe_price_id} }; | |
| 455 | } | |
| 456 | ||
| 457 | # Decide interval. Stripe natively supports day/week/month/year. | |
| 458 | # 30 day plans use interval=month, others use day with count. | |
| 459 | my $cad = int($plan->{cadence_days} || 30) || 30; | |
| 460 | my ($interval, $count); | |
| 461 | if ($cad == 7) { $interval = 'week'; $count = 1; } | |
| 462 | elsif ($cad == 14) { $interval = 'week'; $count = 2; } | |
| 463 | elsif ($cad == 30) { $interval = 'month'; $count = 1; } | |
| 464 | elsif ($cad == 60) { $interval = 'month'; $count = 2; } | |
| 465 | elsif ($cad == 90) { $interval = 'month'; $count = 3; } | |
| 466 | elsif ($cad == 365) { $interval = 'year'; $count = 1; } | |
| 467 | else { $interval = 'day'; $count = $cad; } | |
| 468 | ||
| 469 | my $prod_id = $plan->{stripe_product_id}; | |
| 470 | unless ($prod_id) { | |
| 471 | my $pr = $stripe->create_product( | |
| 472 | name => $plan->{name}, | |
| 473 | description => substr($plan->{description} || '', 0, 220), | |
| 474 | metadata => { shopcart_plan_id => $plan->{id} }, | |
| 475 | ); | |
| 476 | return { error => $pr->{error} } if $pr->{error}; | |
| 477 | $prod_id = $pr->{id}; | |
| 478 | my $esc = $prod_id; $esc =~ s/'/''/g; | |
| 479 | $db->db_readwrite($dbh, qq~ | |
| 480 | UPDATE `${DB}`.subscription_plans SET stripe_product_id='$esc' | |
| 481 | WHERE id='$plan_id' LIMIT 1 | |
| 482 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 483 | } | |
| 484 | ||
| 485 | my $price = $stripe->create_price( | |
| 486 | product => $prod_id, | |
| 487 | amount_cents => $plan->{price_cents}, | |
| 488 | currency => lc($plan->{currency} || 'usd'), | |
| 489 | interval => $interval, | |
| 490 | interval_count => $count, | |
| 491 | metadata => { shopcart_plan_id => $plan->{id} }, | |
| 492 | ); | |
| 493 | return { error => $price->{error} } if $price->{error}; | |
| 494 | my $price_id = $price->{id}; | |
| 495 | my $esc = $price_id; $esc =~ s/'/''/g; | |
| 496 | $db->db_readwrite($dbh, qq~ | |
| 497 | UPDATE `${DB}`.subscription_plans SET stripe_price_id='$esc' | |
| 498 | WHERE id='$plan_id' LIMIT 1 | |
| 499 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 500 | ||
| 501 | return { product => $prod_id, price => $price_id }; | |
| 502 | } | |
| 503 | ||
| 504 | # Look up a buyer_subscription by Stripe subscription id. Used by the | |
| 505 | # webhook to match invoice.paid / customer.subscription.deleted back | |
| 506 | # to a buyer row. | |
| 507 | sub by_stripe_subscription_id { | |
| 508 | my ($self, $db, $dbh, $DB, $stripe_sub_id) = @_; | |
| 509 | return undef unless $stripe_sub_id && $self->schema_ready($db, $dbh, $DB); | |
| 510 | my $esc = $stripe_sub_id; $esc =~ s/'/''/g; | |
| 511 | my $r = $db->db_readwrite($dbh, qq~ | |
| 512 | SELECT * FROM `${DB}`.buyer_subscriptions | |
| 513 | WHERE stripe_subscription_id='$esc' LIMIT 1 | |
| 514 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 515 | return ($r && $r->{id}) ? $r : undef; | |
| 516 | } | |
| 517 | ||
| 518 | # Activate / refresh a buyer_subscription after a successful charge. | |
| 519 | # Called from stripe_webhook on invoice.paid -- bumps the period | |
| 520 | # forward + zeros quotas. | |
| 521 | sub activate_from_stripe { | |
| 522 | my ($self, $db, $dbh, $DB, %p) = @_; | |
| 523 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 524 | my $sub_id = $p{buyer_sub_id}; | |
| 525 | my $cust = $p{stripe_customer_id} || ''; | |
| 526 | $sub_id =~ s/[^0-9]//g; | |
| 527 | return 0 unless length $sub_id; | |
| 528 | my $sub = $db->db_readwrite($dbh, qq~ | |
| 529 | SELECT bs.id, sp.cadence_days | |
| 530 | FROM `${DB}`.buyer_subscriptions bs | |
| 531 | JOIN `${DB}`.subscription_plans sp ON sp.id = bs.plan_id | |
| 532 | WHERE bs.id='$sub_id' LIMIT 1 | |
| 533 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 534 | return 0 unless $sub; | |
| 535 | my $cad = int($sub->{cadence_days} || 30); | |
| 536 | my $cust_esc = $cust; $cust_esc =~ s/'/''/g; | |
| 537 | my $cust_set = length($cust_esc) ? ", stripe_customer_id='$cust_esc'" : ''; | |
| 538 | $db->db_readwrite($dbh, qq~ | |
| 539 | UPDATE `${DB}`.buyer_subscriptions | |
| 540 | SET status='active', | |
| 541 | current_period_start=NOW(), | |
| 542 | current_period_end=DATE_ADD(NOW(), INTERVAL $cad DAY), | |
| 543 | downloads_used_this_period=0, | |
| 544 | shipments_used_this_period=0$cust_set | |
| 545 | WHERE id='$sub_id' LIMIT 1 | |
| 546 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 547 | return 1; | |
| 548 | } | |
| 549 | ||
| 550 | 1; |