added on WebSTLs (webstls.com) at 2026-07-01 22:26:40
| 1 | package MODS::WebSTLs::R2Sign; | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs - Cloudflare R2 pre-signed URL generator (AWS sigv4). | |
| 4 | # | |
| 5 | # R2 is S3-compatible -- the same Signature Version 4 algorithm used | |
| 6 | # by AWS S3 produces a working URL against R2's endpoint. We never | |
| 7 | # install AWS SDKs; sigv4 is just HMAC-SHA256 over a deterministic | |
| 8 | # canonical string, all of which is in core perl via Digest::SHA. | |
| 9 | # | |
| 10 | # Public surface: | |
| 11 | # $r2 = MODS::WebSTLs::R2Sign->new; | |
| 12 | # $r2->is_configured -> 1 once Software Config has account_id + | |
| 13 | # access_key_id + secret_access_key | |
| 14 | # $r2->presigned_get_url( -> "https://<acct>.r2.cloudflarestorage.com/<bucket>/<key>?X-Amz-..." | |
| 15 | # key => 'models/abc/foo.stl', | |
| 16 | # bucket => 'webstls-files', # optional, defaults to Config r2_bucket | |
| 17 | # expires => 600, # optional, default 600s | |
| 18 | # response_content_disposition => 'attachment; filename="foo.stl"', # optional | |
| 19 | # ); | |
| 20 | # | |
| 21 | # Errors return undef. Caller falls back to a 404 / "remote storage | |
| 22 | # not configured" message; download.cgi already has that path. | |
| 23 | # | |
| 24 | # Algorithm reference: | |
| 25 | # https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html | |
| 26 | # | |
| 27 | # We sign ONLY the Host header (and any explicitly-named response-* | |
| 28 | # query parameters). UNSIGNED-PAYLOAD is the payload hash because GET | |
| 29 | # has no body and we don't want to force the client to stream-hash | |
| 30 | # the response. | |
| 31 | #====================================================================== | |
| 32 | ||
| 33 | use strict; | |
| 34 | use warnings; | |
| 35 | use Digest::SHA qw(hmac_sha256 hmac_sha256_hex sha256_hex); | |
| 36 | use MODS::WebSTLs::Config; | |
| 37 | ||
| 38 | sub new { | |
| 39 | my ($class) = @_; | |
| 40 | my $cfg = MODS::WebSTLs::Config->new; | |
| 41 | my $self = { | |
| 42 | cfg => $cfg, | |
| 43 | account_id => $cfg->settings('r2_account_id') || '', | |
| 44 | access_key => $cfg->settings('r2_access_key_id') || '', | |
| 45 | secret_key => $cfg->settings('r2_secret_access_key') || '', | |
| 46 | bucket => $cfg->settings('r2_bucket') || '', | |
| 47 | region => $cfg->settings('r2_region') || 'auto', | |
| 48 | }; | |
| 49 | return bless $self, $class; | |
| 50 | } | |
| 51 | ||
| 52 | sub is_configured { | |
| 53 | my $self = shift; | |
| 54 | return (length $self->{account_id} | |
| 55 | && length $self->{access_key} | |
| 56 | && length $self->{secret_key} | |
| 57 | && length $self->{bucket}) ? 1 : 0; | |
| 58 | } | |
| 59 | ||
| 60 | # Mint a pre-signed GET URL. Returns undef on misconfiguration or | |
| 61 | # unsafe input (empty key, etc.). The expires window is clamped to | |
| 62 | # 7 days -- AWS sigv4 max -- and floors at 60 seconds so a clock- | |
| 63 | # skewed client still has a working URL. | |
| 64 | sub presigned_get_url { | |
| 65 | my ($self, %p) = @_; | |
| 66 | return undef unless $self->is_configured; | |
| 67 | ||
| 68 | my $key = $p{key}; | |
| 69 | return undef unless defined $key && length $key; | |
| 70 | ||
| 71 | my $bucket = $p{bucket} || $self->{bucket}; | |
| 72 | my $expires = int($p{expires} || 600); | |
| 73 | $expires = 60 if $expires < 60; | |
| 74 | $expires = 7 * 86400 if $expires > 7 * 86400; | |
| 75 | ||
| 76 | my $now = _utc_now(); | |
| 77 | my $amzdate = $now->{amzdate}; # YYYYMMDDTHHMMSSZ | |
| 78 | my $datestamp= $now->{datestamp}; # YYYYMMDD | |
| 79 | my $region = $self->{region}; | |
| 80 | my $service = 's3'; | |
| 81 | my $algo = 'AWS4-HMAC-SHA256'; | |
| 82 | my $scope = "$datestamp/$region/$service/aws4_request"; | |
| 83 | my $cred = $self->{access_key} . '/' . $scope; | |
| 84 | ||
| 85 | my $host = $self->{account_id} . '.r2.cloudflarestorage.com'; | |
| 86 | ||
| 87 | # Canonical URI: bucket then key, each path segment url-encoded | |
| 88 | # (but slashes between segments preserved). | |
| 89 | my $canon_uri = '/' . _uri_encode_path($bucket) . '/' . _uri_encode_path($key); | |
| 90 | ||
| 91 | # Query parameters in canonical (alphabetical) order. Required by | |
| 92 | # the sigv4 spec -- the canonical string sorts these and the | |
| 93 | # client URL must include them in the same order to verify. | |
| 94 | my %qs = ( | |
| 95 | 'X-Amz-Algorithm' => $algo, | |
| 96 | 'X-Amz-Credential' => $cred, | |
| 97 | 'X-Amz-Date' => $amzdate, | |
| 98 | 'X-Amz-Expires' => $expires, | |
| 99 | 'X-Amz-SignedHeaders' => 'host', | |
| 100 | ); | |
| 101 | ||
| 102 | # Optional response-* overrides: let the caller force the | |
| 103 | # downstream Content-Disposition so the user's browser saves | |
| 104 | # with the original filename even though the object key in R2 | |
| 105 | # might be opaque (e.g. UUID-based). | |
| 106 | if (defined $p{response_content_disposition}) { | |
| 107 | $qs{'response-content-disposition'} = $p{response_content_disposition}; | |
| 108 | } | |
| 109 | if (defined $p{response_content_type}) { | |
| 110 | $qs{'response-content-type'} = $p{response_content_type}; | |
| 111 | } | |
| 112 | ||
| 113 | my @sorted_keys = sort keys %qs; | |
| 114 | my $canon_qs = join('&', map { | |
| 115 | _amz_encode($_) . '=' . _amz_encode($qs{$_}) | |
| 116 | } @sorted_keys); | |
| 117 | ||
| 118 | my $canon_headers = "host:$host\n"; | |
| 119 | my $signed_headers = 'host'; | |
| 120 | my $payload_hash = 'UNSIGNED-PAYLOAD'; | |
| 121 | ||
| 122 | my $canon_request = "GET\n" | |
| 123 | . "$canon_uri\n" | |
| 124 | . "$canon_qs\n" | |
| 125 | . "$canon_headers\n" | |
| 126 | . "$signed_headers\n" | |
| 127 | . $payload_hash; | |
| 128 | ||
| 129 | my $string_to_sign = "$algo\n" | |
| 130 | . "$amzdate\n" | |
| 131 | . "$scope\n" | |
| 132 | . sha256_hex($canon_request); | |
| 133 | ||
| 134 | # Derive the signing key. Each step HMACs the previous with the | |
| 135 | # next scope segment -- "k_secret" -> "k_date" -> "k_region" -> | |
| 136 | # "k_service" -> "k_signing". | |
| 137 | my $k_date = hmac_sha256($datestamp, 'AWS4' . $self->{secret_key}); | |
| 138 | my $k_region = hmac_sha256($region, $k_date); | |
| 139 | my $k_service = hmac_sha256($service, $k_region); | |
| 140 | my $k_signing = hmac_sha256('aws4_request', $k_service); | |
| 141 | ||
| 142 | my $signature = hmac_sha256_hex($string_to_sign, $k_signing); | |
| 143 | ||
| 144 | return "https://$host$canon_uri?$canon_qs&X-Amz-Signature=$signature"; | |
| 145 | } | |
| 146 | ||
| 147 | # ---- Helpers -------------------------------------------------------- | |
| 148 | ||
| 149 | # Get current UTC time as both ISO-compact (YYYYMMDDTHHMMSSZ) and | |
| 150 | # date-only (YYYYMMDD) strings. Computed from gmtime() so the host's | |
| 151 | # local TZ doesn't matter. | |
| 152 | sub _utc_now { | |
| 153 | my @t = gmtime(); | |
| 154 | my $datestamp = sprintf('%04d%02d%02d', $t[5]+1900, $t[4]+1, $t[3]); | |
| 155 | my $amzdate = sprintf('%04d%02d%02dT%02d%02d%02dZ', | |
| 156 | $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]); | |
| 157 | return { amzdate => $amzdate, datestamp => $datestamp }; | |
| 158 | } | |
| 159 | ||
| 160 | # AWS percent-encoding for query strings + non-slash URI parts. Same | |
| 161 | # rules as RFC 3986 unreserved set -- A-Z a-z 0-9 - _ . ~ pass through | |
| 162 | # unchanged, everything else is %HH. The trailing-tilde quirk (some | |
| 163 | # encoders escape ~) matters because sigv4 requires the canonical | |
| 164 | # string to match the URL byte-for-byte. | |
| 165 | sub _amz_encode { | |
| 166 | my $s = shift; | |
| 167 | $s = '' unless defined $s; | |
| 168 | $s =~ s/([^A-Za-z0-9\-_.~])/sprintf('%%%02X', ord($1))/ge; | |
| 169 | return $s; | |
| 170 | } | |
| 171 | ||
| 172 | # Same as _amz_encode but preserves '/' so the path keeps its segment | |
| 173 | # structure. Encode each segment, then re-join. | |
| 174 | sub _uri_encode_path { | |
| 175 | my $path = shift; | |
| 176 | return '' unless defined $path && length $path; | |
| 177 | return join('/', map { _amz_encode($_) } split(/\//, $path, -1)); | |
| 178 | } | |
| 179 | ||
| 180 | 1; |