diff options
Diffstat (limited to 'Bugzilla/S3.pm')
| -rw-r--r-- | Bugzilla/S3.pm | 479 |
1 files changed, 241 insertions, 238 deletions
diff --git a/Bugzilla/S3.pm b/Bugzilla/S3.pm index 26d77562f..ceb1451fa 100644 --- a/Bugzilla/S3.pm +++ b/Bugzilla/S3.pm @@ -28,7 +28,7 @@ use XML::Simple; use base qw(Class::Accessor::Fast); __PACKAGE__->mk_accessors( - qw(aws_access_key_id aws_secret_access_key secure ua err errstr timeout retry host) + qw(aws_access_key_id aws_secret_access_key secure ua err errstr timeout retry host) ); our $VERSION = '0.45bmo'; @@ -37,148 +37,149 @@ my $METADATA_PREFIX = 'x-amz-meta-'; my $KEEP_ALIVE_CACHESIZE = 10; sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - - die "No aws_access_key_id" unless $self->aws_access_key_id; - die "No aws_secret_access_key" unless $self->aws_secret_access_key; - - $self->secure(1) if not defined $self->secure; - $self->timeout(30) if not defined $self->timeout; - $self->host('s3.amazonaws.com') if not defined $self->host; - - my $ua; - if ($self->retry) { - require LWP::UserAgent::Determined; - $ua = LWP::UserAgent::Determined->new( - keep_alive => $KEEP_ALIVE_CACHESIZE, - requests_redirectable => [qw(GET HEAD DELETE PUT)], - ); - $ua->timing('1,2,4,8,16,32'); - } - else { - $ua = LWP::UserAgent->new( - keep_alive => $KEEP_ALIVE_CACHESIZE, - requests_redirectable => [qw(GET HEAD DELETE PUT)], - ); - } - - $ua->timeout($self->timeout); - if (my $proxy = Bugzilla->params->{proxy_url}) { - $ua->proxy([ 'https', 'http' ], $proxy); - } - $self->ua($ua); - return $self; + my $class = shift; + my $self = $class->SUPER::new(@_); + + die "No aws_access_key_id" unless $self->aws_access_key_id; + die "No aws_secret_access_key" unless $self->aws_secret_access_key; + + $self->secure(1) if not defined $self->secure; + $self->timeout(30) if not defined $self->timeout; + $self->host('s3.amazonaws.com') if not defined $self->host; + + my $ua; + if ($self->retry) { + require LWP::UserAgent::Determined; + $ua = LWP::UserAgent::Determined->new( + keep_alive => $KEEP_ALIVE_CACHESIZE, + requests_redirectable => [qw(GET HEAD DELETE PUT)], + ); + $ua->timing('1,2,4,8,16,32'); + } + else { + $ua = LWP::UserAgent->new( + keep_alive => $KEEP_ALIVE_CACHESIZE, + requests_redirectable => [qw(GET HEAD DELETE PUT)], + ); + } + + $ua->timeout($self->timeout); + if (my $proxy = Bugzilla->params->{proxy_url}) { + $ua->proxy(['https', 'http'], $proxy); + } + $self->ua($ua); + return $self; } sub bucket { - my ($self, $bucketname) = @_; - return Bugzilla::S3::Bucket->new({bucket => $bucketname, account => $self}); + my ($self, $bucketname) = @_; + return Bugzilla::S3::Bucket->new({bucket => $bucketname, account => $self}); } sub _validate_acl_short { - my ($self, $policy_name) = @_; - - if (!grep({$policy_name eq $_} - qw(private public-read public-read-write authenticated-read))) - { - croak "$policy_name is not a supported canned access policy"; - } + my ($self, $policy_name) = @_; + + if ( + !grep({ $policy_name eq $_ } + qw(private public-read public-read-write authenticated-read))) + { + croak "$policy_name is not a supported canned access policy"; + } } # EU buckets must be accessed via their DNS name. This routine figures out if # a given bucket name can be safely used as a DNS name. sub _is_dns_bucket { - my $bucketname = $_[0]; + my $bucketname = $_[0]; - if (length $bucketname > 63) { - return 0; - } - if (length $bucketname < 3) { - return; - } - return 0 unless $bucketname =~ m{^[a-z0-9][a-z0-9.-]+$}; - my @components = split /\./, $bucketname; - for my $c (@components) { - return 0 if $c =~ m{^-}; - return 0 if $c =~ m{-$}; - return 0 if $c eq ''; - } - return 1; + if (length $bucketname > 63) { + return 0; + } + if (length $bucketname < 3) { + return; + } + return 0 unless $bucketname =~ m{^[a-z0-9][a-z0-9.-]+$}; + my @components = split /\./, $bucketname; + for my $c (@components) { + return 0 if $c =~ m{^-}; + return 0 if $c =~ m{-$}; + return 0 if $c eq ''; + } + return 1; } # make the HTTP::Request object sub _make_request { - my ($self, $method, $path, $headers, $data, $metadata) = @_; - croak 'must specify method' unless $method; - croak 'must specify path' unless defined $path; - $headers ||= {}; - $data = '' if not defined $data; - $metadata ||= {}; - my $http_headers = $self->_merge_meta($headers, $metadata); - - $self->_add_auth_header($http_headers, $method, $path) - unless exists $headers->{Authorization}; - my $protocol = $self->secure ? 'https' : 'http'; - my $host = $self->host; - my $url = "$protocol://$host/$path"; - if ($path =~ m{^([^/?]+)(.*)} && _is_dns_bucket($1)) { - $url = "$protocol://$1.$host$2"; - } - - my $request = HTTP::Request->new($method, $url, $http_headers); - $request->content($data); - - # my $req_as = $request->as_string; - # $req_as =~ s/[^\n\r\x20-\x7f]/?/g; - # $req_as = substr( $req_as, 0, 1024 ) . "\n\n"; - # warn $req_as; - - return $request; + my ($self, $method, $path, $headers, $data, $metadata) = @_; + croak 'must specify method' unless $method; + croak 'must specify path' unless defined $path; + $headers ||= {}; + $data = '' if not defined $data; + $metadata ||= {}; + my $http_headers = $self->_merge_meta($headers, $metadata); + + $self->_add_auth_header($http_headers, $method, $path) + unless exists $headers->{Authorization}; + my $protocol = $self->secure ? 'https' : 'http'; + my $host = $self->host; + my $url = "$protocol://$host/$path"; + if ($path =~ m{^([^/?]+)(.*)} && _is_dns_bucket($1)) { + $url = "$protocol://$1.$host$2"; + } + + my $request = HTTP::Request->new($method, $url, $http_headers); + $request->content($data); + + # my $req_as = $request->as_string; + # $req_as =~ s/[^\n\r\x20-\x7f]/?/g; + # $req_as = substr( $req_as, 0, 1024 ) . "\n\n"; + # warn $req_as; + + return $request; } # $self->_send_request($HTTP::Request) # $self->_send_request(@params_to_make_request) sub _send_request { - my $self = shift; - my $request; - if (@_ == 1) { - $request = shift; - } - else { - $request = $self->_make_request(@_); - } + my $self = shift; + my $request; + if (@_ == 1) { + $request = shift; + } + else { + $request = $self->_make_request(@_); + } - my $response = $self->_do_http($request); - my $content = $response->content; + my $response = $self->_do_http($request); + my $content = $response->content; - return $content unless $response->content_type eq 'application/xml'; - return unless $content; - return $self->_xpc_of_content($content); + return $content unless $response->content_type eq 'application/xml'; + return unless $content; + return $self->_xpc_of_content($content); } # centralize all HTTP work, for debugging sub _do_http { - my ($self, $request, $filename) = @_; + my ($self, $request, $filename) = @_; - # convenient time to reset any error conditions - $self->err(undef); - $self->errstr(undef); - return $self->ua->request($request, $filename); + # convenient time to reset any error conditions + $self->err(undef); + $self->errstr(undef); + return $self->ua->request($request, $filename); } sub _send_request_expect_nothing { - my $self = shift; - my $request = $self->_make_request(@_); + my $self = shift; + my $request = $self->_make_request(@_); - my $response = $self->_do_http($request); - my $content = $response->content; + my $response = $self->_do_http($request); + my $content = $response->content; - return 1 if $response->code =~ /^2\d\d$/; + return 1 if $response->code =~ /^2\d\d$/; - # anything else is a failure, and we save the parsed result - $self->_remember_errors($response->content); - return 0; + # anything else is a failure, and we save the parsed result + $self->_remember_errors($response->content); + return 0; } # Send a HEAD request first, to find out if we'll be hit with a 307 redirect. @@ -189,185 +190,187 @@ sub _send_request_expect_nothing { # first time we used it. Thus, we need to probe first to find out what's going on, # before we start sending any actual data. sub _send_request_expect_nothing_probed { - my $self = shift; - my ($method, $path, $conf, $value) = @_; - my $request = $self->_make_request('HEAD', $path); - my $override_uri = undef; + my $self = shift; + my ($method, $path, $conf, $value) = @_; + my $request = $self->_make_request('HEAD', $path); + my $override_uri = undef; - my $old_redirectable = $self->ua->requests_redirectable; - $self->ua->requests_redirectable([]); + my $old_redirectable = $self->ua->requests_redirectable; + $self->ua->requests_redirectable([]); - my $response = $self->_do_http($request); + my $response = $self->_do_http($request); - if ($response->code =~ /^3/ && defined $response->header('Location')) { - $override_uri = $response->header('Location'); - } - $request = $self->_make_request(@_); - $request->uri($override_uri) if defined $override_uri; + if ($response->code =~ /^3/ && defined $response->header('Location')) { + $override_uri = $response->header('Location'); + } + $request = $self->_make_request(@_); + $request->uri($override_uri) if defined $override_uri; - $response = $self->_do_http($request); - $self->ua->requests_redirectable($old_redirectable); + $response = $self->_do_http($request); + $self->ua->requests_redirectable($old_redirectable); - my $content = $response->content; + my $content = $response->content; - return 1 if $response->code =~ /^2\d\d$/; + return 1 if $response->code =~ /^2\d\d$/; - # anything else is a failure, and we save the parsed result - $self->_remember_errors($response->content); - return 0; + # anything else is a failure, and we save the parsed result + $self->_remember_errors($response->content); + return 0; } sub _check_response { - my ($self, $response) = @_; - return 1 if $response->code =~ /^2\d\d$/; - $self->err("network_error"); - $self->errstr($response->status_line); - $self->_remember_errors($response->content); - return undef; + my ($self, $response) = @_; + return 1 if $response->code =~ /^2\d\d$/; + $self->err("network_error"); + $self->errstr($response->status_line); + $self->_remember_errors($response->content); + return undef; } sub _croak_if_response_error { - my ($self, $response) = @_; - unless ($response->code =~ /^2\d\d$/) { - $self->err("network_error"); - $self->errstr($response->status_line); - croak "Bugzilla::S3: Amazon responded with " - . $response->status_line . "\n"; - } + my ($self, $response) = @_; + unless ($response->code =~ /^2\d\d$/) { + $self->err("network_error"); + $self->errstr($response->status_line); + croak "Bugzilla::S3: Amazon responded with " . $response->status_line . "\n"; + } } sub _xpc_of_content { - return XMLin($_[1], 'KeepRoot' => 1, 'SuppressEmpty' => '', 'ForceArray' => ['Contents']); + return XMLin( + $_[1], + 'KeepRoot' => 1, + 'SuppressEmpty' => '', + 'ForceArray' => ['Contents'] + ); } # returns 1 if errors were found sub _remember_errors { - my ($self, $src) = @_; + my ($self, $src) = @_; - unless (ref $src || $src =~ m/^[[:space:]]*</) { # if not xml - (my $code = $src) =~ s/^[[:space:]]*\([0-9]*\).*$/$1/; - $self->err($code); - $self->errstr($src); - return 1; - } + unless (ref $src || $src =~ m/^[[:space:]]*</) { # if not xml + (my $code = $src) =~ s/^[[:space:]]*\([0-9]*\).*$/$1/; + $self->err($code); + $self->errstr($src); + return 1; + } - my $r = ref $src ? $src : $self->_xpc_of_content($src); + my $r = ref $src ? $src : $self->_xpc_of_content($src); - if ($r->{Error}) { - $self->err($r->{Error}{Code}); - $self->errstr($r->{Error}{Message}); - return 1; - } - return 0; + if ($r->{Error}) { + $self->err($r->{Error}{Code}); + $self->errstr($r->{Error}{Message}); + return 1; + } + return 0; } sub _add_auth_header { - my ($self, $headers, $method, $path) = @_; - my $aws_access_key_id = $self->aws_access_key_id; - my $aws_secret_access_key = $self->aws_secret_access_key; - - if (not $headers->header('Date')) { - $headers->header(Date => time2str(time)); - } - my $canonical_string = $self->_canonical_string($method, $path, $headers); - my $encoded_canonical = - $self->_encode($aws_secret_access_key, $canonical_string); - $headers->header( - Authorization => "AWS $aws_access_key_id:$encoded_canonical"); + my ($self, $headers, $method, $path) = @_; + my $aws_access_key_id = $self->aws_access_key_id; + my $aws_secret_access_key = $self->aws_secret_access_key; + + if (not $headers->header('Date')) { + $headers->header(Date => time2str(time)); + } + my $canonical_string = $self->_canonical_string($method, $path, $headers); + my $encoded_canonical + = $self->_encode($aws_secret_access_key, $canonical_string); + $headers->header(Authorization => "AWS $aws_access_key_id:$encoded_canonical"); } # generates an HTTP::Headers objects given one hash that represents http # headers to set and another hash that represents an object's metadata. sub _merge_meta { - my ($self, $headers, $metadata) = @_; - $headers ||= {}; - $metadata ||= {}; - - my $http_header = HTTP::Headers->new; - while (my ($k, $v) = each %$headers) { - $http_header->header($k => $v); - } - while (my ($k, $v) = each %$metadata) { - $http_header->header("$METADATA_PREFIX$k" => $v); - } - - return $http_header; + my ($self, $headers, $metadata) = @_; + $headers ||= {}; + $metadata ||= {}; + + my $http_header = HTTP::Headers->new; + while (my ($k, $v) = each %$headers) { + $http_header->header($k => $v); + } + while (my ($k, $v) = each %$metadata) { + $http_header->header("$METADATA_PREFIX$k" => $v); + } + + return $http_header; } # generate a canonical string for the given parameters. expires is optional and is # only used by query string authentication. sub _canonical_string { - my ($self, $method, $path, $headers, $expires) = @_; - my %interesting_headers = (); - while (my ($key, $value) = each %$headers) { - my $lk = lc $key; - if ( $lk eq 'content-md5' - or $lk eq 'content-type' - or $lk eq 'date' - or $lk =~ /^$AMAZON_HEADER_PREFIX/) - { - $interesting_headers{$lk} = trim($value); - } + my ($self, $method, $path, $headers, $expires) = @_; + my %interesting_headers = (); + while (my ($key, $value) = each %$headers) { + my $lk = lc $key; + if ( $lk eq 'content-md5' + or $lk eq 'content-type' + or $lk eq 'date' + or $lk =~ /^$AMAZON_HEADER_PREFIX/) + { + $interesting_headers{$lk} = trim($value); } + } - # these keys get empty strings if they don't exist - $interesting_headers{'content-type'} ||= ''; - $interesting_headers{'content-md5'} ||= ''; - - # just in case someone used this. it's not necessary in this lib. - $interesting_headers{'date'} = '' - if $interesting_headers{'x-amz-date'}; - - # if you're using expires for query string auth, then it trumps date - # (and x-amz-date) - $interesting_headers{'date'} = $expires if $expires; - - my $buf = "$method\n"; - foreach my $key (sort keys %interesting_headers) { - if ($key =~ /^$AMAZON_HEADER_PREFIX/) { - $buf .= "$key:$interesting_headers{$key}\n"; - } - else { - $buf .= "$interesting_headers{$key}\n"; - } - } + # these keys get empty strings if they don't exist + $interesting_headers{'content-type'} ||= ''; + $interesting_headers{'content-md5'} ||= ''; - # don't include anything after the first ? in the resource... - $path =~ /^([^?]*)/; - $buf .= "/$1"; + # just in case someone used this. it's not necessary in this lib. + $interesting_headers{'date'} = '' if $interesting_headers{'x-amz-date'}; - # ...unless there is an acl or torrent parameter - if ($path =~ /[&?]acl($|=|&)/) { - $buf .= '?acl'; - } - elsif ($path =~ /[&?]torrent($|=|&)/) { - $buf .= '?torrent'; + # if you're using expires for query string auth, then it trumps date + # (and x-amz-date) + $interesting_headers{'date'} = $expires if $expires; + + my $buf = "$method\n"; + foreach my $key (sort keys %interesting_headers) { + if ($key =~ /^$AMAZON_HEADER_PREFIX/) { + $buf .= "$key:$interesting_headers{$key}\n"; } - elsif ($path =~ /[&?]location($|=|&)/) { - $buf .= '?location'; + else { + $buf .= "$interesting_headers{$key}\n"; } - - return $buf; + } + + # don't include anything after the first ? in the resource... + $path =~ /^([^?]*)/; + $buf .= "/$1"; + + # ...unless there is an acl or torrent parameter + if ($path =~ /[&?]acl($|=|&)/) { + $buf .= '?acl'; + } + elsif ($path =~ /[&?]torrent($|=|&)/) { + $buf .= '?torrent'; + } + elsif ($path =~ /[&?]location($|=|&)/) { + $buf .= '?location'; + } + + return $buf; } # finds the hmac-sha1 hash of the canonical string and the aws secret access key and then # base64 encodes the result (optionally urlencoding after that). sub _encode { - my ($self, $aws_secret_access_key, $str, $urlencode) = @_; - my $hmac = Digest::HMAC_SHA1->new($aws_secret_access_key); - $hmac->add($str); - my $b64 = encode_base64($hmac->digest, ''); - if ($urlencode) { - return $self->_urlencode($b64); - } - else { - return $b64; - } + my ($self, $aws_secret_access_key, $str, $urlencode) = @_; + my $hmac = Digest::HMAC_SHA1->new($aws_secret_access_key); + $hmac->add($str); + my $b64 = encode_base64($hmac->digest, ''); + if ($urlencode) { + return $self->_urlencode($b64); + } + else { + return $b64; + } } sub _urlencode { - my ($self, $unencoded) = @_; - return uri_escape_utf8($unencoded, '^A-Za-z0-9_-'); + my ($self, $unencoded) = @_; + return uri_escape_utf8($unencoded, '^A-Za-z0-9_-'); } 1; |