added on WebSTLs (webstls.com) at 2026-07-01 22:26:41
| 1 | package MODS::WebSTLs::Storage; | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs -- per-user storage caps + upload gate. | |
| 4 | # | |
| 5 | # One decision point for every upload path: | |
| 6 | # ($ok, $err) = $storage->check_upload_allowed($db, $dbh, $DB, | |
| 7 | # $uid, $size_bytes, $ext) | |
| 8 | # Returns (1, undef) when within caps; (0, "...") with an | |
| 9 | # admin-style reason otherwise. | |
| 10 | # | |
| 11 | # Three layers, in order of precedence (highest first): | |
| 12 | # 1. users.*_override columns (admin-set on /admin_user.cgi) | |
| 13 | # 2. platform_settings tier defaults (admin-set on /admin_config.cgi) | |
| 14 | # 3. Hardcoded fallbacks (last-resort -- normal installs never hit) | |
| 15 | # | |
| 16 | # Usage tracking is denormalized on users.storage_used_bytes (cheap | |
| 17 | # to read, kept in sync by bump_usage() on upload + the hourly | |
| 18 | # recompute worker for drift correction). | |
| 19 | #====================================================================== | |
| 20 | use strict; | |
| 21 | use warnings; | |
| 22 | ||
| 23 | use MODS::WebSTLs::Config; | |
| 24 | ||
| 25 | my $cfg = MODS::WebSTLs::Config->new; | |
| 26 | ||
| 27 | # Hardcoded last-resort defaults. platform_settings rows from the | |
| 28 | # storage v1 migration override these; the migration ships sane values | |
| 29 | # so these effectively only fire on a fresh install before the | |
| 30 | # migration runs. | |
| 31 | my %TIER_UPLOAD_MB_DEFAULTS = ( | |
| 32 | free => 25, starter => 100, pro => 500, studio => 2048, | |
| 33 | ); | |
| 34 | my %TIER_HARD_CAP_GB_DEFAULTS = ( | |
| 35 | free => 1, starter => 10, pro => 100, studio => 1024, | |
| 36 | ); | |
| 37 | my $EXT_DEFAULTS = 'stl,obj,3mf,step,stp,iges,igs,fbx,ply,glb,gltf'; | |
| 38 | ||
| 39 | sub new { | |
| 40 | my ($class) = @_; | |
| 41 | return bless({}, $class); | |
| 42 | } | |
| 43 | ||
| 44 | sub _setting { | |
| 45 | my ($key, $fallback) = @_; | |
| 46 | my $v = $cfg->settings($key); | |
| 47 | return (defined $v && $v ne '') ? $v : $fallback; | |
| 48 | } | |
| 49 | ||
| 50 | #--------------------------------------------------------------------- | |
| 51 | # Tier resolution -- normalize whatever the user has on users.plan_tier | |
| 52 | # to the four tier names that platform_settings keys index off. | |
| 53 | #--------------------------------------------------------------------- | |
| 54 | sub _tier_for_user { | |
| 55 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 56 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 57 | return 'free' unless $uid; | |
| 58 | my $r = $db->db_readwrite($dbh, qq~ | |
| 59 | SELECT plan_tier FROM `${DB}`.users WHERE id='$uid' LIMIT 1 | |
| 60 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 61 | my $t = ($r && $r->{plan_tier}) ? lc $r->{plan_tier} : 'free'; | |
| 62 | return $TIER_UPLOAD_MB_DEFAULTS{$t} ? $t : 'free'; | |
| 63 | } | |
| 64 | ||
| 65 | #--------------------------------------------------------------------- | |
| 66 | # limits_for_user -> { | |
| 67 | # tier => 'pro', | |
| 68 | # upload_max_bytes => N, | |
| 69 | # upload_max_mb => M, | |
| 70 | # hard_cap_bytes => N, | |
| 71 | # hard_cap_gb => G, | |
| 72 | # allowed_exts => ['stl','obj',...], | |
| 73 | # used_bytes => U, | |
| 74 | # pct_of_cap => 0-100, | |
| 75 | # over_cap => 0/1, | |
| 76 | # warn => 0/1 (used >= soft_alert_pct AND < 100) | |
| 77 | # src_upload_mb => 'override' | 'tier_setting' | 'fallback' | |
| 78 | # src_hard_cap_gb => same | |
| 79 | # src_allowed_exts => same | |
| 80 | # } | |
| 81 | #--------------------------------------------------------------------- | |
| 82 | sub limits_for_user { | |
| 83 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 84 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 85 | ||
| 86 | my $u = $uid ? $db->db_readwrite($dbh, qq~ | |
| 87 | SELECT plan_tier, | |
| 88 | upload_max_mb_override, | |
| 89 | storage_hard_cap_gb_override, | |
| 90 | allowed_extensions_override, | |
| 91 | storage_used_bytes | |
| 92 | FROM `${DB}`.users WHERE id='$uid' LIMIT 1 | |
| 93 | ~, $ENV{SCRIPT_NAME}, __LINE__) : undef; | |
| 94 | ||
| 95 | my $tier = ($u && $u->{plan_tier}) ? lc $u->{plan_tier} : 'free'; | |
| 96 | $tier = 'free' unless $TIER_UPLOAD_MB_DEFAULTS{$tier}; | |
| 97 | ||
| 98 | # ---- per-file upload cap ---------------------------------------- | |
| 99 | my ($upload_mb, $src_upload); | |
| 100 | if ($u && defined $u->{upload_max_mb_override} | |
| 101 | && $u->{upload_max_mb_override} ne '') { | |
| 102 | $upload_mb = int $u->{upload_max_mb_override}; | |
| 103 | $src_upload = 'override'; | |
| 104 | } else { | |
| 105 | my $key = "upload_max_mb_$tier"; | |
| 106 | my $v = _setting($key, undef); | |
| 107 | if (defined $v) { | |
| 108 | $upload_mb = int $v; | |
| 109 | $src_upload = 'tier_setting'; | |
| 110 | } else { | |
| 111 | $upload_mb = $TIER_UPLOAD_MB_DEFAULTS{$tier}; | |
| 112 | $src_upload = 'fallback'; | |
| 113 | } | |
| 114 | } | |
| 115 | ||
| 116 | # ---- total storage cap ------------------------------------------ | |
| 117 | my ($hard_gb, $src_hard); | |
| 118 | if ($u && defined $u->{storage_hard_cap_gb_override} | |
| 119 | && $u->{storage_hard_cap_gb_override} ne '') { | |
| 120 | $hard_gb = int $u->{storage_hard_cap_gb_override}; | |
| 121 | $src_hard = 'override'; | |
| 122 | } else { | |
| 123 | my $key = "storage_hard_cap_gb_$tier"; | |
| 124 | my $v = _setting($key, undef); | |
| 125 | if (defined $v) { | |
| 126 | $hard_gb = int $v; | |
| 127 | $src_hard = 'tier_setting'; | |
| 128 | } else { | |
| 129 | $hard_gb = $TIER_HARD_CAP_GB_DEFAULTS{$tier}; | |
| 130 | $src_hard = 'fallback'; | |
| 131 | } | |
| 132 | } | |
| 133 | ||
| 134 | # ---- allowed extensions ----------------------------------------- | |
| 135 | # Resolution: user override > per-tier setting > legacy global | |
| 136 | # setting > hardcoded fallback. Per-tier keys are | |
| 137 | # platform_settings.allowed_file_extensions_<tier>. | |
| 138 | my ($ext_csv, $src_ext); | |
| 139 | if ($u && defined $u->{allowed_extensions_override} | |
| 140 | && $u->{allowed_extensions_override} ne '') { | |
| 141 | $ext_csv = $u->{allowed_extensions_override}; | |
| 142 | $src_ext = 'override'; | |
| 143 | } else { | |
| 144 | my $tier_key = "allowed_file_extensions_$tier"; | |
| 145 | my $v_tier = _setting($tier_key, undef); | |
| 146 | if (defined $v_tier) { | |
| 147 | $ext_csv = $v_tier; | |
| 148 | $src_ext = 'tier_setting'; | |
| 149 | } else { | |
| 150 | my $v_global = _setting('allowed_file_extensions', undef); | |
| 151 | if (defined $v_global) { | |
| 152 | $ext_csv = $v_global; | |
| 153 | $src_ext = 'global_setting'; | |
| 154 | } else { | |
| 155 | $ext_csv = $EXT_DEFAULTS; | |
| 156 | $src_ext = 'fallback'; | |
| 157 | } | |
| 158 | } | |
| 159 | } | |
| 160 | my @exts = map { my $x = lc $_; $x =~ s/^\s+|\s+$//g; $x =~ s/^\.//; $x } split /,/, $ext_csv; | |
| 161 | @exts = grep { /^[a-z0-9]{1,8}$/ } @exts; | |
| 162 | ||
| 163 | my $used_b = ($u && defined $u->{storage_used_bytes}) ? int($u->{storage_used_bytes}) : 0; | |
| 164 | my $hard_b = int $hard_gb * 1024 * 1024 * 1024; | |
| 165 | my $upload_b = int $upload_mb * 1024 * 1024; | |
| 166 | my $pct = $hard_b > 0 ? int($used_b * 100 / $hard_b) : 0; | |
| 167 | my $soft_pct = int(_setting('storage_soft_alert_pct', 80)); | |
| 168 | $soft_pct = 80 unless $soft_pct; | |
| 169 | ||
| 170 | return { | |
| 171 | tier => $tier, | |
| 172 | upload_max_bytes => $upload_b, | |
| 173 | upload_max_mb => $upload_mb, | |
| 174 | hard_cap_bytes => $hard_b, | |
| 175 | hard_cap_gb => $hard_gb, | |
| 176 | allowed_exts => \@exts, | |
| 177 | used_bytes => $used_b, | |
| 178 | pct_of_cap => $pct, | |
| 179 | over_cap => ($used_b >= $hard_b ? 1 : 0), | |
| 180 | warn => ($pct >= $soft_pct && $pct < 100 ? 1 : 0), | |
| 181 | src_upload_mb => $src_upload, | |
| 182 | src_hard_cap_gb => $src_hard, | |
| 183 | src_allowed_exts => $src_ext, | |
| 184 | }; | |
| 185 | } | |
| 186 | ||
| 187 | #--------------------------------------------------------------------- | |
| 188 | # check_upload_allowed(uid, size_bytes, file_ext) -> (1, undef) | (0, msg) | |
| 189 | # Gate ALL upload CGIs through this. | |
| 190 | #--------------------------------------------------------------------- | |
| 191 | sub check_upload_allowed { | |
| 192 | my ($self, $db, $dbh, $DB, $uid, $size, $ext) = @_; | |
| 193 | $size = 0 unless defined $size && $size >= 0; | |
| 194 | $ext = '' unless defined $ext; | |
| 195 | $ext = lc $ext; | |
| 196 | $ext =~ s/^\.//; | |
| 197 | ||
| 198 | my $L = $self->limits_for_user($db, $dbh, $DB, $uid); | |
| 199 | ||
| 200 | # Extension | |
| 201 | my %ok_ext = map { $_ => 1 } @{ $L->{allowed_exts} }; | |
| 202 | unless ($ok_ext{$ext}) { | |
| 203 | my $accepted = join(', ', map { ".$_" } @{ $L->{allowed_exts} }); | |
| 204 | return (0, "Sorry, .$ext files aren't allowed on the $L->{tier} plan. Accepted: $accepted"); | |
| 205 | } | |
| 206 | ||
| 207 | # Per-file size | |
| 208 | if ($size > $L->{upload_max_bytes}) { | |
| 209 | return (0, sprintf( | |
| 210 | "This file is %s but the %s plan caps single uploads at %d MB. Upgrade or split the file.", | |
| 211 | human_size($size), $L->{tier}, $L->{upload_max_mb} | |
| 212 | )); | |
| 213 | } | |
| 214 | ||
| 215 | # Total storage cap (post-upload projection) | |
| 216 | my $projected = $L->{used_bytes} + $size; | |
| 217 | if ($projected > $L->{hard_cap_bytes}) { | |
| 218 | my $remaining = $L->{hard_cap_bytes} - $L->{used_bytes}; | |
| 219 | $remaining = 0 if $remaining < 0; | |
| 220 | return (0, sprintf( | |
| 221 | "This upload would put you over your %d GB storage cap (using %s of %d GB; %s remaining). Delete some models or upgrade.", | |
| 222 | $L->{hard_cap_gb}, human_size($L->{used_bytes}), $L->{hard_cap_gb}, human_size($remaining) | |
| 223 | )); | |
| 224 | } | |
| 225 | ||
| 226 | return (1, undef); | |
| 227 | } | |
| 228 | ||
| 229 | #--------------------------------------------------------------------- | |
| 230 | # bump_usage(uid, delta_bytes) -- positive for upload, negative for | |
| 231 | # delete. Caller is responsible for sign. No-op for $uid=0. | |
| 232 | #--------------------------------------------------------------------- | |
| 233 | sub bump_usage { | |
| 234 | my ($self, $db, $dbh, $DB, $uid, $delta) = @_; | |
| 235 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 236 | return 0 unless $uid; | |
| 237 | $delta = int($delta || 0); | |
| 238 | return 1 unless $delta; | |
| 239 | # MariaDB UNSIGNED arithmetic: clamp at zero on subtract. | |
| 240 | if ($delta < 0) { | |
| 241 | my $abs = -$delta; | |
| 242 | $db->db_readwrite($dbh, qq~ | |
| 243 | UPDATE `${DB}`.users | |
| 244 | SET storage_used_bytes = GREATEST( | |
| 245 | CAST(storage_used_bytes AS SIGNED) - $abs, 0) | |
| 246 | WHERE id='$uid' | |
| 247 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 248 | } else { | |
| 249 | $db->db_readwrite($dbh, qq~ | |
| 250 | UPDATE `${DB}`.users | |
| 251 | SET storage_used_bytes = storage_used_bytes + $delta | |
| 252 | WHERE id='$uid' | |
| 253 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 254 | } | |
| 255 | return 1; | |
| 256 | } | |
| 257 | ||
| 258 | #--------------------------------------------------------------------- | |
| 259 | # recompute_usage(uid) -- authoritative sum of THIS user's model_files, | |
| 260 | # pre-compression (original_size_bytes when set, file_size_bytes | |
| 261 | # fallback). Writes both storage_used_bytes and | |
| 262 | # storage_used_at_recompute. Called by the hourly worker + admin | |
| 263 | # "Recompute" button. | |
| 264 | #--------------------------------------------------------------------- | |
| 265 | sub recompute_usage { | |
| 266 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 267 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 268 | return 0 unless $uid; | |
| 269 | ||
| 270 | my $r = $db->db_readwrite($dbh, qq~ | |
| 271 | SELECT COALESCE(SUM( | |
| 272 | COALESCE(mf.original_size_bytes, mf.file_size_bytes, 0) | |
| 273 | ), 0) AS total | |
| 274 | FROM `${DB}`.model_files mf | |
| 275 | JOIN `${DB}`.models m ON m.id = mf.model_id | |
| 276 | WHERE m.user_id='$uid' | |
| 277 | AND COALESCE(m.purged_at, '1970-01-01') < '1970-01-02' | |
| 278 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 279 | my $total = ($r && defined $r->{total}) ? int($r->{total}) : 0; | |
| 280 | ||
| 281 | $db->db_readwrite($dbh, qq~ | |
| 282 | UPDATE `${DB}`.users | |
| 283 | SET storage_used_bytes='$total', | |
| 284 | storage_used_at_recompute=NOW() | |
| 285 | WHERE id='$uid' | |
| 286 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 287 | return $total; | |
| 288 | } | |
| 289 | ||
| 290 | #--------------------------------------------------------------------- | |
| 291 | # Convenience helpers for the admin + dashboard UIs. | |
| 292 | #--------------------------------------------------------------------- | |
| 293 | sub users_at_capacity { | |
| 294 | my ($self, $db, $dbh, $DB, $threshold_pct) = @_; | |
| 295 | $threshold_pct = 80 unless defined $threshold_pct; | |
| 296 | my $soft = _setting('storage_soft_alert_pct', $threshold_pct); | |
| 297 | # Pull every user + recompute their effective cap; cheap enough at | |
| 298 | # the scale this product runs. | |
| 299 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 300 | SELECT id FROM `${DB}`.users ORDER BY id ASC | |
| 301 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 302 | my @out; | |
| 303 | foreach my $r (@rows) { | |
| 304 | my $L = $self->limits_for_user($db, $dbh, $DB, $r->{id}); | |
| 305 | push @out, { user_id => $r->{id}, pct => $L->{pct_of_cap} } | |
| 306 | if $L->{pct_of_cap} >= $soft; | |
| 307 | } | |
| 308 | return \@out; | |
| 309 | } | |
| 310 | ||
| 311 | sub users_needing_soft_alert { | |
| 312 | my ($self, $db, $dbh, $DB) = @_; | |
| 313 | my $soft = int(_setting('storage_soft_alert_pct', 80)); | |
| 314 | $soft = 80 unless $soft; | |
| 315 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 316 | SELECT id, last_storage_alert_at, storage_used_bytes | |
| 317 | FROM `${DB}`.users | |
| 318 | ORDER BY id ASC | |
| 319 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 320 | my @out; | |
| 321 | foreach my $r (@rows) { | |
| 322 | my $L = $self->limits_for_user($db, $dbh, $DB, $r->{id}); | |
| 323 | next unless $L->{pct_of_cap} >= $soft; | |
| 324 | # Dedupe: don't re-alert within 7 days. | |
| 325 | if ($r->{last_storage_alert_at}) { | |
| 326 | my $d = $db->db_readwrite($dbh, qq~ | |
| 327 | SELECT TIMESTAMPDIFF(DAY, '$r->{last_storage_alert_at}', NOW()) AS d | |
| 328 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 329 | next if $d && $d->{d} < 7; | |
| 330 | } | |
| 331 | push @out, { user_id => $r->{id}, pct => $L->{pct_of_cap}, used_bytes => $L->{used_bytes} }; | |
| 332 | } | |
| 333 | return \@out; | |
| 334 | } | |
| 335 | ||
| 336 | #--------------------------------------------------------------------- | |
| 337 | # human_size(bytes) -> '1.4 GB' / '256 MB' / '4.2 KB' / '512 B' | |
| 338 | #--------------------------------------------------------------------- | |
| 339 | sub human_size { | |
| 340 | my $b = shift; | |
| 341 | $b = 0 unless defined $b && $b =~ /^-?\d+$/; | |
| 342 | return '0 B' if $b == 0; | |
| 343 | my $abs = $b < 0 ? -$b : $b; | |
| 344 | my $sign = $b < 0 ? '-' : ''; | |
| 345 | if ($abs >= 1024**3) { return sprintf('%s%.1f GB', $sign, $abs / 1024**3); } | |
| 346 | if ($abs >= 1024**2) { return sprintf('%s%.1f MB', $sign, $abs / 1024**2); } | |
| 347 | if ($abs >= 1024) { return sprintf('%s%.1f KB', $sign, $abs / 1024); } | |
| 348 | return sprintf('%s%d B', $sign, $abs); | |
| 349 | } | |
| 350 | ||
| 351 | 1; |