added on WebSTLs (webstls.com) at 2026-07-01 22:26:38
| 1 | package MODS::WebSTLs::Compress; | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs -- on-store compression for model uploads. | |
| 4 | # | |
| 5 | # Two operations + one detector: | |
| 6 | # | |
| 7 | # ($ok, $algo, $bytes_written, $err) = compress_file($src, $dst) | |
| 8 | # Compresses $src into $dst using zstd (preferred) or gzip. | |
| 9 | # Returns the algo actually used ('zstd' / 'gzip' / 'none') | |
| 10 | # so the caller stamps it on model_files.compression_algo. | |
| 11 | # | |
| 12 | # ($ok, $bytes, $err) = decompress_to_handle($src, $algo, $fh) | |
| 13 | # Streams the decompressed bytes from $src to $fh. Used by | |
| 14 | # download.cgi so the buyer sees the original file even though | |
| 15 | # on-disk is compressed. | |
| 16 | # | |
| 17 | # is_already_compressed($path_or_ext) -> 1/0 | |
| 18 | # Cheap detector for formats that are already-packed. 3MF is | |
| 19 | # zip-based; GLB is binary-packed; FBX binary is partly packed | |
| 20 | # (we leave it raw -- the extra savings are small and a corrupt | |
| 21 | # FBX is worse than a few wasted MB). Saves us double-compressing | |
| 22 | # formats where it'd be wasted CPU + negligible bytes saved. | |
| 23 | # | |
| 24 | # Algo selection: reads platform_settings.storage_compression_algo. | |
| 25 | # 'auto' -> zstd if /usr/bin/zstd is present, else gzip | |
| 26 | # 'zstd' -> force zstd (refuses to fall back; admin signaled intent) | |
| 27 | # 'gzip' -> force gzip | |
| 28 | # | |
| 29 | # Whether to compress at all is gated on platform_settings. | |
| 30 | # storage_compression_enabled (default 1). | |
| 31 | #====================================================================== | |
| 32 | use strict; | |
| 33 | use warnings; | |
| 34 | ||
| 35 | use MODS::WebSTLs::Config; | |
| 36 | ||
| 37 | my $cfg = MODS::WebSTLs::Config->new; | |
| 38 | ||
| 39 | # Cache the algo decision per process (avoids hitting platform_settings | |
| 40 | # + filesystem on every upload). | |
| 41 | my $_cached_algo; | |
| 42 | sub _resolve_algo { | |
| 43 | return $_cached_algo if defined $_cached_algo; | |
| 44 | my $enabled = $cfg->settings('storage_compression_enabled'); | |
| 45 | if (defined $enabled && $enabled eq '0') { | |
| 46 | $_cached_algo = 'none'; | |
| 47 | return $_cached_algo; | |
| 48 | } | |
| 49 | my $pref = $cfg->settings('storage_compression_algo') || 'auto'; | |
| 50 | $pref = lc $pref; | |
| 51 | if ($pref eq 'zstd' || ($pref eq 'auto' && -x '/usr/bin/zstd')) { | |
| 52 | $_cached_algo = -x '/usr/bin/zstd' ? 'zstd' : 'gzip'; | |
| 53 | } elsif ($pref eq 'gzip' || $pref eq 'auto') { | |
| 54 | $_cached_algo = 'gzip'; | |
| 55 | } else { | |
| 56 | $_cached_algo = 'none'; | |
| 57 | } | |
| 58 | return $_cached_algo; | |
| 59 | } | |
| 60 | ||
| 61 | sub new { | |
| 62 | my ($class) = @_; | |
| 63 | return bless({}, $class); | |
| 64 | } | |
| 65 | ||
| 66 | #--------------------------------------------------------------------- | |
| 67 | # Magic-byte detection. STL ASCII / OBJ / STEP / IGES are plaintext and | |
| 68 | # compress brilliantly. 3MF / GLB / FBX binary already pack their own | |
| 69 | # bytes; we skip them. | |
| 70 | #--------------------------------------------------------------------- | |
| 71 | sub is_already_compressed { | |
| 72 | my ($path_or_ext) = @_; | |
| 73 | return 0 unless defined $path_or_ext && length $path_or_ext; | |
| 74 | # First, ext shortcut -- cheaper than opening a file. | |
| 75 | my $ext = lc $path_or_ext; | |
| 76 | $ext =~ s/.*\.//; | |
| 77 | return 1 if $ext eq '3mf'; # 3MF is a zip container | |
| 78 | return 1 if $ext eq 'glb'; # binary glTF, partly packed | |
| 79 | return 1 if $ext eq 'zip'; | |
| 80 | return 1 if $ext eq 'gz'; | |
| 81 | return 1 if $ext eq 'zst'; | |
| 82 | return 1 if $ext eq 'xz'; | |
| 83 | return 1 if $ext eq '7z'; | |
| 84 | ||
| 85 | # If we were given a real path, peek the first 4 bytes for magic. | |
| 86 | if (-f $path_or_ext) { | |
| 87 | if (open(my $fh, '<:raw', $path_or_ext)) { | |
| 88 | my $buf = ''; | |
| 89 | read($fh, $buf, 4); | |
| 90 | close $fh; | |
| 91 | # PK\x03\x04 = ZIP, 1F 8B = gzip, 28 B5 2F FD = zstd | |
| 92 | return 1 if substr($buf,0,2) eq "PK"; | |
| 93 | return 1 if substr($buf,0,2) eq "\x1F\x8B"; | |
| 94 | return 1 if substr($buf,0,4) eq "\x28\xB5\x2F\xFD"; | |
| 95 | } | |
| 96 | } | |
| 97 | return 0; | |
| 98 | } | |
| 99 | ||
| 100 | #--------------------------------------------------------------------- | |
| 101 | # compress_file($src, $dst) -> (ok, algo, bytes_written, err) | |
| 102 | # | |
| 103 | # Streams $src through the selected compressor and writes the result | |
| 104 | # to $dst. Returns ('none') when compression is disabled OR the input | |
| 105 | # is already a packed format -- in that case the caller should | |
| 106 | # rename / move the file rather than calling this. | |
| 107 | # | |
| 108 | # Uses system() so we get the C-implementation throughput. Both zstd | |
| 109 | # and gzip handle stdin->stdout streaming, so we avoid loading the | |
| 110 | # whole file into Perl memory. | |
| 111 | #--------------------------------------------------------------------- | |
| 112 | sub compress_file { | |
| 113 | my ($self, $src, $dst) = @_; | |
| 114 | return (0, 'none', 0, 'source missing') unless $src && -f $src; | |
| 115 | return (0, 'none', 0, 'destination required') unless $dst; | |
| 116 | ||
| 117 | if (is_already_compressed($src)) { | |
| 118 | return (1, 'none', -s $src, undef); # caller should mv $src $dst | |
| 119 | } | |
| 120 | my $algo = _resolve_algo(); | |
| 121 | return (1, 'none', -s $src, undef) if $algo eq 'none'; | |
| 122 | ||
| 123 | my @cmd; | |
| 124 | if ($algo eq 'zstd') { | |
| 125 | # -19 = high compression, --long=27 = 128MB window for big STL | |
| 126 | # files, --quiet to silence the stderr banner. | |
| 127 | @cmd = ('/usr/bin/zstd', '-19', '--long=27', '--quiet', '-o', $dst, $src); | |
| 128 | } elsif ($algo eq 'gzip') { | |
| 129 | # gzip writes to stdout when -c is set, so we redirect. | |
| 130 | @cmd = ('sh', '-c', "/usr/bin/gzip -9 -c " . _shellquote($src) . " > " . _shellquote($dst)); | |
| 131 | } else { | |
| 132 | return (0, 'none', 0, "unknown algo $algo"); | |
| 133 | } | |
| 134 | ||
| 135 | my $rc = system(@cmd); | |
| 136 | if ($rc != 0) { | |
| 137 | unlink $dst if -e $dst; | |
| 138 | return (0, $algo, 0, "compressor exited $rc"); | |
| 139 | } | |
| 140 | return (1, $algo, -s $dst, undef); | |
| 141 | } | |
| 142 | ||
| 143 | #--------------------------------------------------------------------- | |
| 144 | # decompress_to_handle($src, $algo, $fh) -- streams decompressed | |
| 145 | # bytes to $fh. Used on download.cgi so buyers receive the original | |
| 146 | # file regardless of how it's stored on disk. | |
| 147 | #--------------------------------------------------------------------- | |
| 148 | sub decompress_to_handle { | |
| 149 | my ($self, $src, $algo, $out_fh) = @_; | |
| 150 | return (0, 0, 'source missing') unless $src && -f $src; | |
| 151 | return (0, 0, 'no output handle') unless $out_fh; | |
| 152 | ||
| 153 | my @cmd; | |
| 154 | if ($algo eq 'zstd') { | |
| 155 | @cmd = ('/usr/bin/zstd', '-d', '-c', '--quiet', $src); | |
| 156 | } elsif ($algo eq 'gzip') { | |
| 157 | @cmd = ('/usr/bin/gzip', '-d', '-c', $src); | |
| 158 | } elsif (!$algo || $algo eq 'none') { | |
| 159 | # Stored uncompressed -- straight passthrough. | |
| 160 | if (open(my $in, '<:raw', $src)) { | |
| 161 | my $bytes = 0; | |
| 162 | my $buf; | |
| 163 | while (read($in, $buf, 65536)) { | |
| 164 | print $out_fh $buf; | |
| 165 | $bytes += length $buf; | |
| 166 | } | |
| 167 | close $in; | |
| 168 | return (1, $bytes, undef); | |
| 169 | } | |
| 170 | return (0, 0, "couldn't open $src"); | |
| 171 | } else { | |
| 172 | return (0, 0, "unknown algo $algo"); | |
| 173 | } | |
| 174 | ||
| 175 | my $pid = open(my $kid, '-|', @cmd); | |
| 176 | return (0, 0, "couldn't spawn $cmd[0]") unless $pid; | |
| 177 | binmode $kid, ':raw'; | |
| 178 | my $bytes = 0; | |
| 179 | my $buf; | |
| 180 | while (read($kid, $buf, 65536)) { | |
| 181 | print $out_fh $buf; | |
| 182 | $bytes += length $buf; | |
| 183 | } | |
| 184 | close $kid; | |
| 185 | return (1, $bytes, undef); | |
| 186 | } | |
| 187 | ||
| 188 | sub resolved_algo { return _resolve_algo(); } | |
| 189 | ||
| 190 | sub _shellquote { | |
| 191 | my $s = shift; | |
| 192 | $s =~ s/'/'\\''/g; | |
| 193 | return "'$s'"; | |
| 194 | } | |
| 195 | ||
| 196 | 1; |