From ff4d8480878988f823989c42bc7472e9712220d1 Mon Sep 17 00:00:00 2001 From: Leon Brocard Date: Mon, 24 Nov 2008 08:39:27 +0000 Subject: [PATCH] import 0.46-tobe from svn --- CHANGES | 83 ++ MANIFEST | 30 + META.yml | 31 + Makefile.PL | 32 + README | 329 +++++++ bin/s3cl | 299 +++++++ examples/backup_cpan.pl | 161 ++++ lib/Net/Amazon/S3.pm | 836 ++++++++++++++++++ lib/Net/Amazon/S3/Bucket.pm | 633 +++++++++++++ lib/Net/Amazon/S3/Client.pm | 199 +++++ lib/Net/Amazon/S3/Client/Bucket.pm | 217 +++++ lib/Net/Amazon/S3/Client/Object.pm | 361 ++++++++ lib/Net/Amazon/S3/HTTPRequest.pm | 214 +++++ lib/Net/Amazon/S3/Request.pm | 65 ++ lib/Net/Amazon/S3/Request/CreateBucket.pm | 63 ++ lib/Net/Amazon/S3/Request/DeleteBucket.pm | 41 + lib/Net/Amazon/S3/Request/DeleteObject.pm | 44 + .../S3/Request/GetBucketAccessControl.pm | 42 + .../S3/Request/GetBucketLocationConstraint.pm | 42 + lib/Net/Amazon/S3/Request/GetObject.pm | 46 + .../S3/Request/GetObjectAccessControl.pm | 44 + lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm | 38 + lib/Net/Amazon/S3/Request/ListBucket.pm | 68 ++ lib/Net/Amazon/S3/Request/PutObject.pm | 58 ++ .../S3/Request/SetBucketAccessControl.pm | 62 ++ .../S3/Request/SetObjectAccessControl.pm | 64 ++ t/01api.t | 379 ++++++++ t/02client.t | 225 +++++ t/99-pod-coverage.t | 13 + t/99-pod.t | 6 + 30 files changed, 4725 insertions(+) create mode 100644 CHANGES create mode 100644 MANIFEST create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100755 bin/s3cl create mode 100755 examples/backup_cpan.pl create mode 100644 lib/Net/Amazon/S3.pm create mode 100644 lib/Net/Amazon/S3/Bucket.pm create mode 100644 lib/Net/Amazon/S3/Client.pm create mode 100644 lib/Net/Amazon/S3/Client/Bucket.pm create mode 100644 lib/Net/Amazon/S3/Client/Object.pm create mode 100644 lib/Net/Amazon/S3/HTTPRequest.pm create mode 100644 lib/Net/Amazon/S3/Request.pm create mode 100644 lib/Net/Amazon/S3/Request/CreateBucket.pm create mode 100644 lib/Net/Amazon/S3/Request/DeleteBucket.pm create mode 100644 lib/Net/Amazon/S3/Request/DeleteObject.pm create mode 100644 lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm create mode 100644 lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm create mode 100644 lib/Net/Amazon/S3/Request/GetObject.pm create mode 100644 lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm create mode 100644 lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm create mode 100644 lib/Net/Amazon/S3/Request/ListBucket.pm create mode 100644 lib/Net/Amazon/S3/Request/PutObject.pm create mode 100644 lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm create mode 100644 lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm create mode 100644 t/01api.t create mode 100644 t/02client.t create mode 100644 t/99-pod-coverage.t create mode 100644 t/99-pod.t diff --git a/CHANGES b/CHANGES new file mode 100644 index 00000000..aa449500 --- /dev/null +++ b/CHANGES @@ -0,0 +1,83 @@ +Revision history for Perl module Net::Amazon::S3: + +0.46 + - refactor request creation into Net::Amazon::S3::Request + and many subclasses + - move to Moose + - add Net::Amazon::S3::Client and subclasses + +0.45 Wed Aug 20 17:06:49 BST 2008 + - make add_key, head_key etc. return all the headers, not + just the X-Amazon ones (patch by Andrew Hanenkamp) + - require IO::File 1.14 (noticed by tsw) + - remove DateTime::Format::Strptime prerequisite as it was not + being used (noticed by Yen-Ming Lee) + - do not try and parse non-XML errors (patch by lostlogic) + - make it possible to store and delete the key "0" + (patch by Joey Hess) + - make it possible to store empty files (patch by BDOLAN) + - add Copy support (patch by BDOLAN) + - add s3cl for command-line access (patch by Leo Lapworth) + +0.44 Thu Mar 27 08:35:59 GMT 2008 + - fix bug with storing files consisting of "0" (thanks to + Martin Atkins) + +0.43 Sat Mar 1 10:55:54 GMT 2008 + - add binmode() to support Windows (thanks to Gabriel Weinberg) + +0.42 Thu Feb 28 06:39:59 GMT 2008 + - add exponential backoff upon temporary errors with the new + retry option + +0.41 Fri Nov 30 10:42:26 GMT 2007 + - fix the expensive tests (patch by BDOLAN) + - added support for EU buckets (patch by BDOLAN) + +0.40 Tue Oct 30 11:40:42 GMT 2007 + - fix for content length with empty keys by Mark A. Hershberger + - get_key and get_key_filename now return content_length + - rewrote synopsis + - added support for common prefix (thanks to Andy Grundman) + +0.39 Sun Aug 19 14:47:01 BST 2007 + - add add_key_filename and get_key_filename which send files + directly from disk - good for large files (Jim Blomo) + - support UTF8 keys (Jim Blomo) + - switch back from Build.PL to Makefile.PL + +0.38 Sun Mar 4 16:43:28 GMT 2007 + - use http_proxy and https_proxy environment variables for proxy + settings (Ask Bjoern Hansen) + - don't add the Authorization header if one is already specified + when making a request - good for allowing caching to resources + that are public. (Ask Bjoern Hansen) + +0.37 Fri Oct 13 19:14:57 BST 2006 + - added support for ACLs (thanks to Gordon McCreight) + +0.36 Sun Sep 10 16:30:39 BST 2006 + - remove extra warning + +0.35 Sun Sep 10 16:25:44 BST 2006 + - added list_bucket_all to stop having to worrying about 'marker' + +0.34 Sun Sep 10 07:27:06 BST 2006 + - added next marker and more docs from Jesse Vincent + +0.33 Sat Aug 26 16:26:37 BST 2006 + - documentation and test cleanup from Jesse Vincent + - use HTTP keep alive (patch by Scott Gifford) + - remove ununused code in _make_request (patch by Scott Gifford) + +0.32 Tue Apr 25 19:51:06 BST 2006 + - fix bug with listing buckets with parameters (thanks to karjala) + +0.31 Tue Apr 4 21:15:02 BST 2006 + - many patches from Brad Fitzpatrick to make change the API, make + return values sane, add err/errstr, make Bucket object + - added a timeout option as suggested by Brad Dixon + - it's the Brad release! + +0.30 Mon Mar 20 20:20:29 GMT 2006 + - initial release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 00000000..f92b0166 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,30 @@ +bin/s3cl +CHANGES +examples/backup_cpan.pl +lib/Net/Amazon/S3.pm +lib/Net/Amazon/S3/Bucket.pm +lib/Net/Amazon/S3/Client.pm +lib/Net/Amazon/S3/Client/Bucket.pm +lib/Net/Amazon/S3/Client/Object.pm +lib/Net/Amazon/S3/HTTPRequest.pm +lib/Net/Amazon/S3/Request.pm +lib/Net/Amazon/S3/Request/CreateBucket.pm +lib/Net/Amazon/S3/Request/DeleteBucket.pm +lib/Net/Amazon/S3/Request/DeleteObject.pm +lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm +lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm +lib/Net/Amazon/S3/Request/GetObject.pm +lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm +lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm +lib/Net/Amazon/S3/Request/ListBucket.pm +lib/Net/Amazon/S3/Request/PutObject.pm +lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm +lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm +Makefile.PL +MANIFEST This list of files +README +t/01api.t +t/02client.t +t/99-pod-coverage.t +t/99-pod.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 00000000..54979f06 --- /dev/null +++ b/META.yml @@ -0,0 +1,31 @@ +--- #YAML:1.0 +name: Net-Amazon-S3 +version: 0.45 +abstract: Use the Amazon S3 - Simple Storage Service +license: perl +author: + - Leon Brocard +generated_by: ExtUtils::MakeMaker version 6.44 +distribution_type: module +requires: + Class::Accessor::Fast: 0 + Data::Stream::Bulk::Callback: 0 + Digest::HMAC_SHA1: 0 + Digest::MD5: 0 + Digest::MD5::File: 0 + File::stat: 0 + HTTP::Date: 0 + HTTP::Status: 0 + IO::File: 1.14 + LWP::UserAgent::Determined: 0 + MIME::Base64: 0 + Moose: 0 + MooseX::StrictConstructor: 0 + Regexp::Common: 0 + Test::More: 0.01 + URI::Escape: 0 + XML::LibXML: 0 + XML::LibXML::XPathContext: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 00000000..5081c7f1 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,32 @@ +#!perl +use strict; +use warnings; +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'Net::Amazon::S3', + VERSION_FROM => 'lib/Net/Amazon/S3.pm', + AUTHOR => 'Leon Brocard ', + ABSTRACT => 'Use the Amazon S3 - Simple Storage Service', + LICENSE => 'perl', + PREREQ_PM => { + 'Class::Accessor::Fast' => '0', + 'Data::Stream::Bulk::Callback' => '0', + 'Digest::HMAC_SHA1' => '0', + 'Digest::MD5' => '0', + 'Digest::MD5::File' => '0', + 'File::stat' => '0', + 'HTTP::Date' => '0', + 'HTTP::Status' => '0', + 'IO::File' => '1.14', + 'LWP::UserAgent::Determined' => '0', + 'MIME::Base64' => '0', + 'Moose' => '0', + 'MooseX::StrictConstructor' => '0', + 'Test::More' => '0.01', + 'Regexp::Common' => '0', + 'XML::LibXML' => '0', + 'XML::LibXML::XPathContext' => '0', + 'URI::Escape' => '0', + } +); + diff --git a/README b/README new file mode 100644 index 00000000..6b24036c --- /dev/null +++ b/README @@ -0,0 +1,329 @@ +NAME + Net::Amazon::S3 - Use the Amazon S3 - Simple Storage Service + +SYNOPSIS + use Net::Amazon::S3; + my $aws_access_key_id = 'fill me in'; + my $aws_secret_access_key = 'fill me in too'; + + my $s3 = Net::Amazon::S3->new( + { aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + } + ); + + # a bucket is a globally-unique directory + # list all buckets that i own + my $response = $s3->buckets; + foreach my $bucket ( @{ $response->{buckets} } ) { + print "You have a bucket: " . $bucket->bucket . "\n"; + } + + # create a new bucket + my $bucketname = 'acmes_photo_backups'; + my $bucket = $s3->add_bucket( { bucket => $bucketname } ) + or die $s3->err . ": " . $s3->errstr; + + # or use an existing bucket + $bucket = $s3->bucket($bucketname); + + # store a file in the bucket + $bucket->add_key_filename( '1.JPG', 'DSC06256.JPG', + { content_type => 'image/jpeg', }, + ) or die $s3->err . ": " . $s3->errstr; + + # store a value in the bucket + $bucket->add_key( 'reminder.txt', 'this is where my photos are backed up' ) + or die $s3->err . ": " . $s3->errstr; + + # list files in the bucket + $response = $bucket->list_all + or die $s3->err . ": " . $s3->errstr; + foreach my $key ( @{ $response->{keys} } ) { + my $key_name = $key->{key}; + my $key_size = $key->{size}; + print "Bucket contains key '$key_name' of size $key_size\n"; + } + + # fetch file from the bucket + $response = $bucket->get_key_filename( '1.JPG', 'GET', 'backup.jpg' ) + or die $s3->err . ": " . $s3->errstr; + + # fetch value from the bucket + $response = $bucket->get_key('reminder.txt') + or die $s3->err . ": " . $s3->errstr; + print "reminder.txt:\n"; + print " content length: " . $response->{content_length} . "\n"; + print " content type: " . $response->{content_type} . "\n"; + print " etag: " . $response->{content_type} . "\n"; + print " content: " . $response->{value} . "\n"; + + # delete keys + $bucket->delete_key('reminder.txt') or die $s3->err . ": " . $s3->errstr; + $bucket->delete_key('1.JPG') or die $s3->err . ": " . $s3->errstr; + + # and finally delete the bucket + $bucket->delete_bucket or die $s3->err . ": " . $s3->errstr; + +DESCRIPTION + This module provides a Perlish interface to Amazon S3. From the + developer blurb: "Amazon S3 is storage for the Internet. It is designed + to make web-scale computing easier for developers. Amazon S3 provides a + simple web services interface that can be used to store and retrieve any + amount of data, at any time, from anywhere on the web. It gives any + developer access to the same highly scalable, reliable, fast, + inexpensive data storage infrastructure that Amazon uses to run its own + global network of web sites. The service aims to maximize benefits of + scale and to pass those benefits on to developers". + + To find out more about S3, please visit: http://s3.amazonaws.com/ + + To use this module you will need to sign up to Amazon Web Services and + provide an "Access Key ID" and " Secret Access Key". If you use this + module, you will incurr costs as specified by Amazon. Please check the + costs. If you use this module with your Access Key ID and Secret Access + Key you must be responsible for these costs. + + I highly recommend reading all about S3, but in a nutshell data is + stored in values. Values are referenced by keys, and keys are stored in + buckets. Bucket names are global. + +METHODS + new + Create a new S3 client object. Takes some arguments: + + aws_access_key_id + Use your Access Key ID as the value of the AWSAccessKeyId parameter + in requests you send to Amazon Web Services (when required). Your + Access Key ID identifies you as the party responsible for the + request. + + aws_secret_access_key + Since your Access Key ID is not encrypted in requests to AWS, it + could be discovered and used by anyone. Services that are not free + require you to provide additional information, a request signature, + to verify that a request containing your unique Access Key ID could + only have come from you. + + DO NOT INCLUDE THIS IN SCRIPTS OR APPLICATIONS YOU DISTRIBUTE. + YOU'LL BE SORRY + + secure + Set this to 1 if you want to use SSL-encrypted connections when + talking to S3. Defaults to 0. + + timeout + How many seconds should your script wait before bailing on a request + to S3? Defaults to 30. + + retry + If this library should retry upon errors. This option is + recommended. This uses exponential backoff with retries after 1, 2, + 4, 8, 16, 32 seconds, as recommended by Amazon. Defaults to off. + + buckets + Returns undef on error, else hashref of results + + add_bucket + Takes a hashref: + + bucket + The name of the bucket you want to add + + acl_short (optional) + See the set_acl subroutine for documenation on the acl_short options + + location_constraint (option) + Sets the location constraint of the new bucket. If left unspecified, + the default S3 datacenter location will be used. Otherwise, you can + set it to 'EU' for a European data center - note that costs are + different. + + Returns 0 on failure, Net::Amazon::S3::Bucket object on success + + bucket BUCKET + Takes a scalar argument, the name of the bucket you're creating + + Returns an (unverified) bucket object from an account. Does no network + access. + + delete_bucket + Takes either a Net::Amazon::S3::Bucket object or a hashref containing + + bucket + The name of the bucket to remove + + Returns false (and fails) if the bucket isn't empty. + + Returns true if the bucket is successfully deleted. + + list_bucket + List all keys in this bucket. + + Takes a hashref of arguments: + + MANDATORY + + bucket + The name of the bucket you want to list keys on + + OPTIONAL + + prefix + Restricts the response to only contain results that begin with the + specified prefix. If you omit this optional argument, the value of + prefix for your query will be the empty string. In other words, the + results will be not be restricted by prefix. + + delimiter + If this optional, Unicode string parameter is included with your + request, then keys that contain the same string between the prefix + and the first occurrence of the delimiter will be rolled up into a + single result element in the CommonPrefixes collection. These + rolled-up keys are not returned elsewhere in the response. For + example, with prefix="USA/" and delimiter="/", the matching keys + "USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized in + the response as a single "USA/Oregon" element in the CommonPrefixes + collection. If an otherwise matching key does not contain the + delimiter after the prefix, it appears in the Contents collection. + + Each element in the CommonPrefixes collection counts as one against + the MaxKeys limit. The rolled-up keys represented by each + CommonPrefixes element do not. If the Delimiter parameter is not + present in your request, keys in the result set will not be + rolled-up and neither the CommonPrefixes collection nor the + NextMarker element will be present in the response. + + max-keys + This optional argument limits the number of results returned in + response to your query. Amazon S3 will return no more than this + number of results, but possibly less. Even if max-keys is not + specified, Amazon S3 will limit the number of results in the + response. Check the IsTruncated flag to see if your results are + incomplete. If so, use the Marker parameter to request the next page + of results. For the purpose of counting max-keys, a 'result' is + either a key in the 'Contents' collection, or a delimited prefix in + the 'CommonPrefixes' collection. So for delimiter requests, max-keys + limits the total number of list results, not just the number of + keys. + + marker + This optional parameter enables pagination of large result sets. + "marker" specifies where in the result set to resume listing. It + restricts the response to only contain results that occur + alphabetically after the value of marker. To retrieve the next page + of results, use the last key from the current page of results as the + marker in your next request. + + See also "next_marker", below. + + If "marker" is omitted,the first page of results is returned. + + Returns undef on error and a hashref of data on success: + + The hashref looks like this: + + { + bucket => $bucket_name, + prefix => $bucket_prefix, + common_prefixes => [$prefix1,$prefix2,...] + marker => $bucket_marker, + next_marker => $bucket_next_available_marker, + max_keys => $bucket_max_keys, + is_truncated => $bucket_is_truncated_boolean + keys => [$key1,$key2,...] + } + + Explanation of bits of that: + + common_prefixes + If list_bucket was requested with a delimiter, common_prefixes will + contain a list of prefixes matching that delimiter. Drill down into + these prefixes by making another request with the prefix parameter. + + is_truncated + B flag that indicates whether or not all results of your query were + returned in this response. If your results were truncated, you can + make a follow-up paginated request using the Marker parameter to + retrieve the rest of the results. + + next_marker + A convenience element, useful when paginating with delimiters. The + value of "next_marker", if present, is the largest (alphabetically) + of all key names and all CommonPrefixes prefixes in the response. If + the "is_truncated" flag is set, request the next page of results by + setting "marker" to the value of "next_marker". This element is only + present in the response if the "delimiter" parameter was sent with + the request. + + Each key is a hashref that looks like this: + + { + key => $key, + last_modified => $last_mod_date, + etag => $etag, # An MD5 sum of the stored content. + size => $size, # Bytes + storage_class => $storage_class # Doc? + owner_id => $owner_id, + owner_displayname => $owner_name + } + + list_bucket_all + List all keys in this bucket without having to worry about 'marker'. + This is a convenience method, but may make multiple requests to S3 under + the hood. + + Takes the same arguments as list_bucket. + + add_key + DEPRECATED. DO NOT USE + + get_key + DEPRECATED. DO NOT USE + + head_key + DEPRECATED. DO NOT USE + + delete_key + DEPRECATED. DO NOT USE + +LICENSE + This module contains code modified from Amazon that contains the + following notice: + + # This software code is made available "AS IS" without warranties of any + # kind. You may copy, display, modify and redistribute the software + # code either by itself or as incorporated into your code; provided that + # you do not remove any proprietary notices. Your use of this software + # code is at your own risk and you waive any claim against Amazon + # Digital Services, Inc. or its affiliates with respect to your use of + # this software code. (c) 2006 Amazon Digital Services, Inc. or its + # affiliates. + +TESTING + Testing S3 is a tricky thing. Amazon wants to charge you a bit of money + each time you use their service. And yes, testing counts as using. + Because of this, the application's test suite skips anything approaching + a real test unless you set these three environment variables: + + AMAZON_S3_EXPENSIVE_TESTS + Doesn't matter what you set it to. Just has to be set + + AWS_ACCESS_KEY_ID + Your AWS access key + + AWS_ACCESS_KEY_SECRET + Your AWS sekkr1t passkey. Be forewarned that setting this + environment variable on a shared system might leak that information + to another user. Be careful. + +AUTHOR + Leon Brocard and unknown Amazon Digital Services + programmers. + + Brad Fitzpatrick - return values, Bucket object + +SEE ALSO + Net::Amazon::S3::Bucket + diff --git a/bin/s3cl b/bin/s3cl new file mode 100755 index 00000000..5eddf92a --- /dev/null +++ b/bin/s3cl @@ -0,0 +1,299 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Getopt::Long; +use Pod::Usage; +use Path::Class; + +# TODO: read key_id and secret from config file? +# use AppConfig; + +# TODO: probably nicer to put all of this in Net::Amazon::S3::CommandLine +# and have simple call to that from here. + +my $aws_access_key_id = $ENV{'AWS_ACCESS_KEY_ID'}; +my $aws_secret_access_key = $ENV{'AWS_ACCESS_KEY_SECRET'}; + +my $s3 = Net::Amazon::S3->new( + { aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + } +); + +=head1 NAME + +s3cl - Command line for Amazon s3 cloud storage + +=head1 SYNOPSIS + +s3cl command [options] + + s3cl buckets + s3cl ls :[prefix] + s3cl cp : /path/[filename] + s3cl sync :[prefix] /path/ + s3cl rm : + + Options: + -help brief help message + -man full documentation + + We take NO responsibility for the costs incured through using + this script. + +=head1 DESCRIPTION + +This program gives a command line interface to Amazons s3 storage +service. It does not limit the number of requests (which may cost +you more money than if you did it a different way!) and each +request costs Money (although some costs from EC2 may be $0.0, +check latest from Amazon costs page) - we take NO reponsibility +for your bill. + +=cut + +my %args; + +my %commands = ( + buckets => \&buckets, + ls => \&ls, + rm => \&rm, + cp => \&cp, + sync => \&sync, + help => \&helper, +); + +terminal(); +get_options(); +main(); + +sub main { + my $command = shift @ARGV || "help"; + $commands{$command} + or helper("Unknown command: $command"); + $commands{$command}->(); +} + +sub sync { + my $dest = $args{dest} || ''; + helper("No destination supplied") if $dest eq ''; + helper("Can not write to: $args{dest}") unless -w $dest; + + my $bucket = _get_bucket(); + + my $list = ls('data'); + foreach my $key ( @{ $list->{keys} } ) { + my $source = file( $key->{key} ); + my $destination = file( $dest, $source ); + $destination->dir->mkpath(); + warn "$source -> $destination"; + my $response + = $bucket->get_key_filename( $source->stringify, 'GET', + $destination->stringify ) + or die $s3->err . ": " . $s3->errstr; + } +} + +sub cp { + my $dest = $args{dest} || ''; + helper("No destination supplied") if $dest eq ''; + + my $key = $args{prefix_or_key} || helper("No key supplied"); + + if ( -d $dest ) { + + # If we have a directory we need to add the file name + $dest = file( $dest, file($key)->basename ); + } + + my $bucket = _get_bucket(); + + unless ( $bucket->get_key_filename( "$key", 'GET', "$dest" ) ) { + die $s3->err . ": " . $s3->errstr if $s3->err; + die "Could not copy $key from bucket $args{bucket}"; + } +} + +sub ls { + my $mode = shift || 'print'; + my $bucket = _get_bucket(); + + my $ls_conf; + $ls_conf->{prefix} = $args{prefix_or_key} if $args{prefix_or_key}; + + # list files in the bucket + my $response = $bucket->list_all($ls_conf) + or die $s3->err . ": " . $s3->errstr; + return $response if $mode eq 'data'; + foreach my $key ( @{ $response->{keys} } ) { + my $key_last_modified + = $key->{last_modified}; # 2008-07-14T22:31:10.000Z + $key_last_modified =~ s/:\d{2}\.\d{3}Z$//; + my $key_name = $key->{key}; + my $key_size = $key->{size}; + print "$key_size $key_last_modified $key_name\n"; + } +} + +sub rm { + my $bucket = _get_bucket(); + + helper("Must have a :") unless $args{prefix_or_key}; + my $res = "NO"; + if ( $args{force} ) { + $res = 'y'; + } else { + print "\nOnce deleted there is no way to retrieve this key again." + . "\nAre you sure you want to delete $args{bucket}:$args{prefix_or_key}? y/N\n"; + ( $res = ) =~ s/\n//; + } + + if ( $res eq 'y' ) { + + # delete key in this bucket + my $response = $bucket->delete_key( $args{prefix_or_key} ) + or die $s3->err . ": " . $s3->errstr; + } +} + +sub buckets { + my $response = $s3->buckets; + my $num = scalar @{ $response->{buckets} || [] }; + print "You have $num bucket"; + print "s" if $num != 1; + print ":\n"; + foreach my $bucket ( @{ $response->{buckets} } ) { + print '- ' . $bucket->bucket . "\n"; + } +} + +sub terminal { + my $encoding = eval { + require Term::Encoding; + Term::Encoding::get_encoding(); + } || "utf-8"; + + binmode STDOUT, ":encoding($encoding)"; +} + +# TODO: Replace with AppConfig this is ick! +sub get_options { + my $help = 0; + my $man = 0; + my $force = 0; + GetOptions( + \%args, "bucket=s", + "f|force" => \$force, + "h|help|?" => \$help, + "man" => \$man, + ) or pod2usage(2); + + $args{force} = $force; + + foreach my $arg (@ARGV) { + if ( $arg =~ /:/ ) { + my ( $b, $rest ) = split( ":", $arg ); + $args{bucket} = $b; + $args{prefix_or_key} = $rest; + } + } + + # For cp + $args{dest} = $ARGV[2] if $ARGV[2]; + + pod2usage(1) if $help || @ARGV == 0; + pod2usage( -verbose => 2 ) if $man; +} + +sub _get_bucket { + helper("No bucket supplied") unless $args{bucket}; + my $bucket = $s3->bucket( $args{bucket} ); + die $s3->err . ": " . $s3->errstr if $s3->err; + helper("Could not get bucket $args{bucket}") unless $bucket; + return $bucket; +} + +sub helper { + my $msg = shift; + if ($msg) { + pod2usage( -message => $msg, -exitval => 2 ); + } + + exit; +} + +__DATA__ + +=head1 COMMANDS + +=over 4 + +=item B + +s3cl buckets + +List all buckets for this account. + +=item B + +s3cl ls :[prefix] + +List contents of a bucket, the optional B can be partial, in which +case all keys matching this as the start of the key name will be returned. +If no B is supplied all keys of the bucket will be returned. + +=item B + +s3cl cp : target_file + +s3cl cp : target_directory + +Copy a single key from the bucket to the target file, or into +the target_directory. + +=item B + +s3cl sync :[prefix] target_dir + +Downloads all files matching the prefix into a directory structure +replicating that of the prefix and all 'sub-directories'. It will +download ALL files - even if already on your local disk: + +http://www.amazon.com/gp/browse.html?node=16427261 + + # Data transfer "in" and "out" refers to transfer into and out + # of Amazon S3. Data transferred between Amazon EC2 and + # Amazon S3, is free of charge (i.e., $0.00 per GB), except + # data transferred between Amazon EC2 and Amazon S3-Europe, + # which will be charged at regular rates. + +=item B + +s3cl rm : + +Remove a key(file) from the bucket, removing a non-existent file +is not classed as an error. Once removed the key (file) can not +be restored - so use with care! + +=back + +=head1 ABOUT + +This module contains code modified from Amazon that contains the +following notice (which is also applicicable to this code): + + # This software code is made available "AS IS" without + # warranties of any kind. You may copy, display, modify and + # redistribute the software code either by itself or as incorporated + # into your code; provided that you do not remove any proprietary + # notices. Your use of this software code is at your own risk and + # you waive any claim against Amazon Digital Services, Inc. or its + # affiliates with respect to your use of this software code. + # (c) 2006 Amazon Digital Services, Inc. or its affiliates. + +=head1 AUTHOR + +Leo Lapworth - Part of the HinuHinu project + +=cut diff --git a/examples/backup_cpan.pl b/examples/backup_cpan.pl new file mode 100755 index 00000000..58e2e5c9 --- /dev/null +++ b/examples/backup_cpan.pl @@ -0,0 +1,161 @@ +#!/home/acme/bin/perl +use strict; +use warnings; +use lib 'lib'; +use Data::Stream::Bulk::Path::Class; +use Net::Amazon::S3; +use Perl6::Say; +use Path::Class; +use Set::Object; +use Term::ProgressBar::Simple; +use List::Util qw(sum); +use Digest::MD5::File qw(file_md5_hex); +use BerkeleyDB::Manager; +use Cwd; +use Config; + +my $m = BerkeleyDB::Manager->new( + home => Path::Class::Dir->new(cwd), + db_class => 'BerkeleyDB::Hash', + create => 1, +); +my $db = $m->open_db( file => 'md5_cache' ); + +my $s3 = Net::Amazon::S3->new( + aws_access_key_id => 'XXX', + aws_secret_access_key => 'XXX', + retry => 1, +); + +my $client = Net::Amazon::S3::Client->new( s3 => $s3 ); +my $bucket = $client->bucket( name => 'minicpan' ); + +my $root = '/home/acme/Public/minicpan/'; + +my $file_stream = Data::Stream::Bulk::Path::Class->new( + dir => Path::Class::Dir->new($root), + only_files => 1, +); + +my %files; +my $file_set = Set::Object->new(); +until ( $file_stream->is_done ) { + foreach my $filename ( $file_stream->items ) { + my $key = $filename->relative($root)->stringify; + + #[rootname]path/to/file.txt:,,, + my $stat = $filename->stat; + my $ctime = $stat->ctime; + my $mtime = $stat->mtime; + my $size = $stat->size; + my $inodenum = $stat->ino; + my $cachekey = "$key:$ctime,$mtime,$size,$inodenum"; + + $db->db_get( $cachekey, my $md5_hex ); + if ($md5_hex) { + + #say "hit $cachekey $md5hex"; + } else { + $md5_hex = file_md5_hex($filename) + || die "Failed to find MD5 for $filename"; + $m->txn_do( + sub { + $db->db_put( $cachekey, $md5_hex ); + } + ); + + #say "miss $cachekey $md5_hex"; + } + $files{$key} = { + filename => $filename, + key => $key, + md5_hex => $md5_hex, + size => -s $filename, + }; + $file_set->insert($key); + + } +} + +my %objects; +my $s3_set = Set::Object->new(); +my $object_stream = $bucket->list; +until ( $object_stream->is_done ) { + foreach my $object ( $object_stream->items ) { + my $key = $object->key; + $objects{$key} = { + filename => file( $root, $key )->stringify, + key => $key, + md5_hex => $object->etag, + size => $object->size, + }; + + # say $object->key . ' ' . $object->size . ' ' . $object->etag; + $s3_set->insert( $object->key ); + } +} + +my @to_add; +my @to_delete; + +foreach my $key ( sort keys %files ) { + my $file = $files{$key}; + my $object = $objects{$key}; + if ($object) { + if ( $file->{md5_hex} eq $object->{md5_hex} ) { + + # say "$key same"; + } else { + + # say "$key different"; + push @to_add, $file; + } + } else { + + #say "$key missing"; + push @to_add, $file; + } +} + +foreach my $key ( sort keys %objects ) { + my $object = $objects{$key}; + my $file = $files{$key}; + if ($file) { + } else { + + # say "$key to delete"; + push @to_delete, $object; + } +} + +my $total_size = sum map { file( $_->{filename} )->stat->size } @to_add; +$total_size += scalar(@to_delete); + +my $progress = Term::ProgressBar::Simple->new($total_size); + +foreach my $file (@to_add) { + my $key = $file->{key}; + my $filename = $file->{filename}; + my $md5_hex = $file->{md5_hex}; + my $size = $file->{size}; + + # say "put $key"; + $progress += $size; + my $object = $bucket->object( + key => $key, + etag => $md5_hex, + size => $size + ); + $object->put_filename($filename); +} + +foreach my $object (@to_delete) { + my $key = $object->{key}; + my $filename = $object->{filename}; + my $object = $bucket->object(key => $key); + + # say "delete $key"; + $object->delete; + $progress++; +} + diff --git a/lib/Net/Amazon/S3.pm b/lib/Net/Amazon/S3.pm new file mode 100644 index 00000000..d21295f4 --- /dev/null +++ b/lib/Net/Amazon/S3.pm @@ -0,0 +1,836 @@ +package Net::Amazon::S3; +use Moose; +use MooseX::StrictConstructor; + +=head1 NAME + +Net::Amazon::S3 - Use the Amazon S3 - Simple Storage Service + +=head1 SYNOPSIS + + use Net::Amazon::S3; + my $aws_access_key_id = 'fill me in'; + my $aws_secret_access_key = 'fill me in too'; + + my $s3 = Net::Amazon::S3->new( + { aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + } + ); + + # a bucket is a globally-unique directory + # list all buckets that i own + my $response = $s3->buckets; + foreach my $bucket ( @{ $response->{buckets} } ) { + print "You have a bucket: " . $bucket->bucket . "\n"; + } + + # create a new bucket + my $bucketname = 'acmes_photo_backups'; + my $bucket = $s3->add_bucket( { bucket => $bucketname } ) + or die $s3->err . ": " . $s3->errstr; + + # or use an existing bucket + $bucket = $s3->bucket($bucketname); + + # store a file in the bucket + $bucket->add_key_filename( '1.JPG', 'DSC06256.JPG', + { content_type => 'image/jpeg', }, + ) or die $s3->err . ": " . $s3->errstr; + + # store a value in the bucket + $bucket->add_key( 'reminder.txt', 'this is where my photos are backed up' ) + or die $s3->err . ": " . $s3->errstr; + + # list files in the bucket + $response = $bucket->list_all + or die $s3->err . ": " . $s3->errstr; + foreach my $key ( @{ $response->{keys} } ) { + my $key_name = $key->{key}; + my $key_size = $key->{size}; + print "Bucket contains key '$key_name' of size $key_size\n"; + } + + # fetch file from the bucket + $response = $bucket->get_key_filename( '1.JPG', 'GET', 'backup.jpg' ) + or die $s3->err . ": " . $s3->errstr; + + # fetch value from the bucket + $response = $bucket->get_key('reminder.txt') + or die $s3->err . ": " . $s3->errstr; + print "reminder.txt:\n"; + print " content length: " . $response->{content_length} . "\n"; + print " content type: " . $response->{content_type} . "\n"; + print " etag: " . $response->{content_type} . "\n"; + print " content: " . $response->{value} . "\n"; + + # delete keys + $bucket->delete_key('reminder.txt') or die $s3->err . ": " . $s3->errstr; + $bucket->delete_key('1.JPG') or die $s3->err . ": " . $s3->errstr; + + # and finally delete the bucket + $bucket->delete_bucket or die $s3->err . ": " . $s3->errstr; + +=head1 DESCRIPTION + +This module provides a Perlish interface to Amazon S3. From the +developer blurb: "Amazon S3 is storage for the Internet. It is +designed to make web-scale computing easier for developers. Amazon S3 +provides a simple web services interface that can be used to store and +retrieve any amount of data, at any time, from anywhere on the web. It +gives any developer access to the same highly scalable, reliable, +fast, inexpensive data storage infrastructure that Amazon uses to run +its own global network of web sites. The service aims to maximize +benefits of scale and to pass those benefits on to developers". + +To find out more about S3, please visit: http://s3.amazonaws.com/ + +To use this module you will need to sign up to Amazon Web Services and +provide an "Access Key ID" and " Secret Access Key". If you use this +module, you will incurr costs as specified by Amazon. Please check the +costs. If you use this module with your Access Key ID and Secret +Access Key you must be responsible for these costs. + +I highly recommend reading all about S3, but in a nutshell data is +stored in values. Values are referenced by keys, and keys are stored +in buckets. Bucket names are global. + +=cut + +use Carp; +use Digest::HMAC_SHA1; + +use Net::Amazon::S3::Bucket; +use Net::Amazon::S3::Client; +use Net::Amazon::S3::Client::Bucket; +use Net::Amazon::S3::Client::Object; +use Net::Amazon::S3::HTTPRequest; +use Net::Amazon::S3::Request; +use Net::Amazon::S3::Request::CreateBucket; +use Net::Amazon::S3::Request::DeleteBucket; +use Net::Amazon::S3::Request::DeleteObject; +use Net::Amazon::S3::Request::GetBucketAccessControl; +use Net::Amazon::S3::Request::GetBucketLocationConstraint; +use Net::Amazon::S3::Request::GetObject; +use Net::Amazon::S3::Request::GetObjectAccessControl; +use Net::Amazon::S3::Request::ListAllMyBuckets; +use Net::Amazon::S3::Request::ListBucket; +use Net::Amazon::S3::Request::PutObject; +use Net::Amazon::S3::Request::SetBucketAccessControl; +use Net::Amazon::S3::Request::SetObjectAccessControl; +use LWP::UserAgent::Determined; +use URI::Escape qw(uri_escape_utf8); +use XML::LibXML; +use XML::LibXML::XPathContext; + +has 'aws_access_key_id' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'aws_secret_access_key' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'secure' => ( is => 'ro', isa => 'Bool', required => 0, default => 0 ); +has 'timeout' => ( is => 'ro', isa => 'Num', required => 0, default => 30 ); +has 'retry' => ( is => 'ro', isa => 'Bool', required => 0, default => 0 ); + +has 'libxml' => ( is => 'rw', isa => 'XML::LibXML', required => 0 ); +has 'ua' => ( is => 'rw', isa => 'LWP::UserAgent', required => 0 ); +has 'err' => ( is => 'rw', isa => 'Maybe[Str]', required => 0 ); +has 'errstr' => ( is => 'rw', isa => 'Maybe[Str]', required => 0 ); + +our $VERSION = '0.45'; + +my $KEEP_ALIVE_CACHESIZE = 10; + +=head1 METHODS + +=head2 new + +Create a new S3 client object. Takes some arguments: + +=over + +=item aws_access_key_id + +Use your Access Key ID as the value of the AWSAccessKeyId parameter +in requests you send to Amazon Web Services (when required). Your +Access Key ID identifies you as the party responsible for the +request. + +=item aws_secret_access_key + +Since your Access Key ID is not encrypted in requests to AWS, it +could be discovered and used by anyone. Services that are not free +require you to provide additional information, a request signature, +to verify that a request containing your unique Access Key ID could +only have come from you. + +DO NOT INCLUDE THIS IN SCRIPTS OR APPLICATIONS YOU DISTRIBUTE. YOU'LL BE SORRY + +=item secure + +Set this to C<1> if you want to use SSL-encrypted connections when talking +to S3. Defaults to C<0>. + +=item timeout + +How many seconds should your script wait before bailing on a request to S3? Defaults +to 30. + +=item retry + +If this library should retry upon errors. This option is recommended. +This uses exponential backoff with retries after 1, 2, 4, 8, 16, 32 seconds, +as recommended by Amazon. Defaults to off. + +=back + +=cut + +sub BUILD { + my $self = shift; + + my $ua; + if ( $self->retry ) { + $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 ); + $ua->env_proxy; + + $self->ua($ua); + $self->libxml( XML::LibXML->new ); +} + +=head2 buckets + +Returns undef on error, else hashref of results + +=cut + +sub buckets { + my $self = shift; + + my $http_request + = Net::Amazon::S3::Request::ListAllMyBuckets->new( s3 => $self ) + ->http_request; + + # die $request->http_request->as_string; + + my $xpc = $self->_send_request($http_request); + + return undef unless $xpc && !$self->_remember_errors($xpc); + + my $owner_id = $xpc->findvalue("//s3:Owner/s3:ID"); + my $owner_displayname = $xpc->findvalue("//s3:Owner/s3:DisplayName"); + + my @buckets; + foreach my $node ( $xpc->findnodes(".//s3:Bucket") ) { + push @buckets, + Net::Amazon::S3::Bucket->new( + { bucket => $xpc->findvalue( ".//s3:Name", $node ), + creation_date => + $xpc->findvalue( ".//s3:CreationDate", $node ), + account => $self, + } + ); + + } + return { + owner_id => $owner_id, + owner_displayname => $owner_displayname, + buckets => \@buckets, + }; +} + +=head2 add_bucket + +Takes a hashref: + +=over + +=item bucket + +The name of the bucket you want to add + +=item acl_short (optional) + +See the set_acl subroutine for documenation on the acl_short options + +=item location_constraint (option) + +Sets the location constraint of the new bucket. If left unspecified, the +default S3 datacenter location will be used. Otherwise, you can set it +to 'EU' for a European data center - note that costs are different. + +=back + +Returns 0 on failure, Net::Amazon::S3::Bucket object on success + +=cut + +sub add_bucket { + my ( $self, $conf ) = @_; + + my $http_request = Net::Amazon::S3::Request::CreateBucket->new( + s3 => $self, + bucket => $conf->{bucket}, + acl_short => $conf->{acl_short}, + location_constraint => $conf->{location_constraint}, + )->http_request; + + return 0 + unless $self->_send_request_expect_nothing($http_request); + + return $self->bucket( $conf->{bucket} ); +} + +=head2 bucket BUCKET + +Takes a scalar argument, the name of the bucket you're creating + +Returns an (unverified) bucket object from an account. Does no network access. + +=cut + +sub bucket { + my ( $self, $bucketname ) = @_; + return Net::Amazon::S3::Bucket->new( + { bucket => $bucketname, account => $self } ); +} + +=head2 delete_bucket + +Takes either a L object or a hashref containing + +=over + +=item bucket + +The name of the bucket to remove + +=back + +Returns false (and fails) if the bucket isn't empty. + +Returns true if the bucket is successfully deleted. + +=cut + +sub delete_bucket { + my ( $self, $conf ) = @_; + my $bucket; + if ( eval { $conf->isa("Net::S3::Amazon::Bucket"); } ) { + $bucket = $conf->bucket; + } else { + $bucket = $conf->{bucket}; + } + croak 'must specify bucket' unless $bucket; + + my $http_request = Net::Amazon::S3::Request::DeleteBucket->new( + s3 => $self, + bucket => $bucket, + )->http_request; + + return $self->_send_request_expect_nothing($http_request); +} + +=head2 list_bucket + +List all keys in this bucket. + +Takes a hashref of arguments: + +MANDATORY + +=over + +=item bucket + +The name of the bucket you want to list keys on + +=back + +OPTIONAL + +=over + +=item prefix + +Restricts the response to only contain results that begin with the +specified prefix. If you omit this optional argument, the value of +prefix for your query will be the empty string. In other words, the +results will be not be restricted by prefix. + +=item delimiter + +If this optional, Unicode string parameter is included with your +request, then keys that contain the same string between the prefix +and the first occurrence of the delimiter will be rolled up into a +single result element in the CommonPrefixes collection. These +rolled-up keys are not returned elsewhere in the response. For +example, with prefix="USA/" and delimiter="/", the matching keys +"USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized +in the response as a single "USA/Oregon" element in the CommonPrefixes +collection. If an otherwise matching key does not contain the +delimiter after the prefix, it appears in the Contents collection. + +Each element in the CommonPrefixes collection counts as one against +the MaxKeys limit. The rolled-up keys represented by each CommonPrefixes +element do not. If the Delimiter parameter is not present in your +request, keys in the result set will not be rolled-up and neither +the CommonPrefixes collection nor the NextMarker element will be +present in the response. + +=item max-keys + +This optional argument limits the number of results returned in +response to your query. Amazon S3 will return no more than this +number of results, but possibly less. Even if max-keys is not +specified, Amazon S3 will limit the number of results in the response. +Check the IsTruncated flag to see if your results are incomplete. +If so, use the Marker parameter to request the next page of results. +For the purpose of counting max-keys, a 'result' is either a key +in the 'Contents' collection, or a delimited prefix in the +'CommonPrefixes' collection. So for delimiter requests, max-keys +limits the total number of list results, not just the number of +keys. + +=item marker + +This optional parameter enables pagination of large result sets. +C specifies where in the result set to resume listing. It +restricts the response to only contain results that occur alphabetically +after the value of marker. To retrieve the next page of results, +use the last key from the current page of results as the marker in +your next request. + +See also C, below. + +If C is omitted,the first page of results is returned. + +=back + + +Returns undef on error and a hashref of data on success: + +The hashref looks like this: + + { + bucket => $bucket_name, + prefix => $bucket_prefix, + common_prefixes => [$prefix1,$prefix2,...] + marker => $bucket_marker, + next_marker => $bucket_next_available_marker, + max_keys => $bucket_max_keys, + is_truncated => $bucket_is_truncated_boolean + keys => [$key1,$key2,...] + } + +Explanation of bits of that: + +=over + +=item common_prefixes + +If list_bucket was requested with a delimiter, common_prefixes will +contain a list of prefixes matching that delimiter. Drill down into +these prefixes by making another request with the prefix parameter. + +=item is_truncated + +B flag that indicates whether or not all results of your query were +returned in this response. If your results were truncated, you can +make a follow-up paginated request using the Marker parameter to +retrieve the rest of the results. + + +=item next_marker + +A convenience element, useful when paginating with delimiters. The +value of C, if present, is the largest (alphabetically) +of all key names and all CommonPrefixes prefixes in the response. +If the C flag is set, request the next page of results +by setting C to the value of C. This element +is only present in the response if the C parameter was +sent with the request. + +=back + +Each key is a hashref that looks like this: + + { + key => $key, + last_modified => $last_mod_date, + etag => $etag, # An MD5 sum of the stored content. + size => $size, # Bytes + storage_class => $storage_class # Doc? + owner_id => $owner_id, + owner_displayname => $owner_name + } + +=cut + +sub list_bucket { + my ( $self, $conf ) = @_; + + my $http_request = Net::Amazon::S3::Request::ListBucket->new( + s3 => $self, + bucket => $conf->{bucket}, + delimiter => $conf->{delimiter}, + max_keys => $conf->{max_keys}, + marker => $conf->{marker}, + )->http_request; + + my $xpc = $self->_send_request($http_request); + + return undef unless $xpc && !$self->_remember_errors($xpc); + + my $return = { + bucket => $xpc->findvalue("//s3:ListBucketResult/s3:Name"), + prefix => $xpc->findvalue("//s3:ListBucketResult/s3:Prefix"), + marker => $xpc->findvalue("//s3:ListBucketResult/s3:Marker"), + next_marker => $xpc->findvalue("//s3:ListBucketResult/s3:NextMarker"), + max_keys => $xpc->findvalue("//s3:ListBucketResult/s3:MaxKeys"), + is_truncated => ( + scalar $xpc->findvalue("//s3:ListBucketResult/s3:IsTruncated") eq + 'true' + ? 1 + : 0 + ), + }; + + my @keys; + foreach my $node ( $xpc->findnodes(".//s3:Contents") ) { + my $etag = $xpc->findvalue( ".//s3:ETag", $node ); + $etag =~ s/^"//; + $etag =~ s/"$//; + + push @keys, + { + key => $xpc->findvalue( ".//s3:Key", $node ), + last_modified => $xpc->findvalue( ".//s3:LastModified", $node ), + etag => $etag, + size => $xpc->findvalue( ".//s3:Size", $node ), + storage_class => $xpc->findvalue( ".//s3:StorageClass", $node ), + owner_id => $xpc->findvalue( ".//s3:ID", $node ), + owner_displayname => + $xpc->findvalue( ".//s3:DisplayName", $node ), + }; + } + $return->{keys} = \@keys; + + if ( $conf->{delimiter} ) { + my @common_prefixes; + my $strip_delim = qr/$conf->{delimiter}$/; + + foreach my $node ( $xpc->findnodes(".//s3:CommonPrefixes") ) { + my $prefix = $xpc->findvalue( ".//s3:Prefix", $node ); + + # strip delimiter from end of prefix + $prefix =~ s/$strip_delim//; + + push @common_prefixes, $prefix; + } + $return->{common_prefixes} = \@common_prefixes; + } + + return $return; +} + +=head2 list_bucket_all + +List all keys in this bucket without having to worry about +'marker'. This is a convenience method, but may make multiple requests +to S3 under the hood. + +Takes the same arguments as list_bucket. + +=cut + +sub list_bucket_all { + my ( $self, $conf ) = @_; + $conf ||= {}; + my $bucket = $conf->{bucket}; + croak 'must specify bucket' unless $bucket; + + my $response = $self->list_bucket($conf); + return $response unless $response->{is_truncated}; + my $all = $response; + + while (1) { + my $next_marker = $response->{next_marker} + || $response->{keys}->[-1]->{key}; + $conf->{marker} = $next_marker; + $conf->{bucket} = $bucket; + $response = $self->list_bucket($conf); + push @{ $all->{keys} }, @{ $response->{keys} }; + last unless $response->{is_truncated}; + } + + delete $all->{is_truncated}; + delete $all->{next_marker}; + return $all; +} + +sub _compat_bucket { + my ( $self, $conf ) = @_; + return Net::Amazon::S3::Bucket->new( + { account => $self, bucket => delete $conf->{bucket} } ); +} + +=head2 add_key + +DEPRECATED. DO NOT USE + +=cut + +# compat wrapper; deprecated as of 2005-03-23 +sub add_key { + my ( $self, $conf ) = @_; + my $bucket = $self->_compat_bucket($conf); + my $key = delete $conf->{key}; + my $value = delete $conf->{value}; + return $bucket->add_key( $key, $value, $conf ); +} + +=head2 get_key + +DEPRECATED. DO NOT USE + +=cut + +# compat wrapper; deprecated as of 2005-03-23 +sub get_key { + my ( $self, $conf ) = @_; + my $bucket = $self->_compat_bucket($conf); + return $bucket->get_key( $conf->{key} ); +} + +=head2 head_key + +DEPRECATED. DO NOT USE + +=cut + +# compat wrapper; deprecated as of 2005-03-23 +sub head_key { + my ( $self, $conf ) = @_; + my $bucket = $self->_compat_bucket($conf); + return $bucket->head_key( $conf->{key} ); +} + +=head2 delete_key + +DEPRECATED. DO NOT USE + +=cut + +# compat wrapper; deprecated as of 2005-03-23 +sub delete_key { + my ( $self, $conf ) = @_; + my $bucket = $self->_compat_bucket($conf); + return $bucket->delete_key( $conf->{key} ); +} + +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"; + } +} + +# $self->_send_request($HTTP::Request) +# $self->_send_request(@params_to_make_request) +sub _send_request { + my ( $self, $http_request ) = @_; + + # warn $http_request->as_string; + + my $response = $self->_do_http($http_request); + my $content = $response->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, $http_request, $filename ) = @_; + + confess 'Need HTTP::Request object' + if ( ref($http_request) ne 'HTTP::Request' ); + + # convenient time to reset any error conditions + $self->err(undef); + $self->errstr(undef); + return $self->ua->request( $http_request, $filename ); +} + +sub _send_request_expect_nothing { + my ( $self, $http_request ) = @_; + + # warn $http_request->as_string; + + my $response = $self->_do_http($http_request); + my $content = $response->content; + + 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; +} + +# Send a HEAD request first, to find out if we'll be hit with a 307 redirect. +# Since currently LWP does not have true support for 100 Continue, it simply +# slams the PUT body into the socket without waiting for any possible redirect. +# Thus when we're reading from a filehandle, when LWP goes to reissue the request +# having followed the redirect, the filehandle's already been closed from the +# 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, $http_request ) = @_; + + my $head = Net::Amazon::S3::HTTPRequest->new( + s3 => $self, + method => 'HEAD', + path => $http_request->uri->path, + )->http_request; + + #my $head_request = $self->_make_request( $head ); + my $override_uri = undef; + + my $old_redirectable = $self->ua->requests_redirectable; + $self->ua->requests_redirectable( [] ); + + my $response = $self->_do_http($head); + + if ( $response->code =~ /^3/ && defined $response->header('Location') ) { + $override_uri = $response->header('Location'); + } + + $http_request->uri($override_uri) if defined $override_uri; + + $response = $self->_do_http($http_request); + $self->ua->requests_redirectable($old_redirectable); + + my $content = $response->content; + + 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; +} + +sub _croak_if_response_error { + my ( $self, $response ) = @_; + unless ( $response->code =~ /^2\d\d$/ ) { + $self->err("network_error"); + $self->errstr( $response->status_line ); + croak "Net::Amazon::S3: Amazon responded with " + . $response->status_line . "\n"; + } +} + +sub _xpc_of_content { + my ( $self, $content ) = @_; + my $doc = $self->libxml->parse_string($content); + + # warn $doc->toString(1); + + my $xpc = XML::LibXML::XPathContext->new($doc); + $xpc->registerNs( 's3', 'http://s3.amazonaws.com/doc/2006-03-01/' ); + + return $xpc; +} + +# returns 1 if errors were found +sub _remember_errors { + my ( $self, $src ) = @_; + + # Do not try to parse non-xml + unless ( ref $src || $src =~ m/^[[:space:]]*err($code); + $self->errstr($src); + return 1; + } + + my $xpc = ref $src ? $src : $self->_xpc_of_content($src); + if ( $xpc->findnodes("//Error") ) { + $self->err( $xpc->findvalue("//Error/Code") ); + $self->errstr( $xpc->findvalue("//Error/Message") ); + return 1; + } + return 0; +} + +sub _urlencode { + my ( $self, $unencoded ) = @_; + return uri_escape_utf8( $unencoded, '^A-Za-z0-9_-' ); +} + +1; + +__END__ + +=head1 LICENSE + +This module contains code modified from Amazon that contains the +following notice: + + # This software code is made available "AS IS" without warranties of any + # kind. You may copy, display, modify and redistribute the software + # code either by itself or as incorporated into your code; provided that + # you do not remove any proprietary notices. Your use of this software + # code is at your own risk and you waive any claim against Amazon + # Digital Services, Inc. or its affiliates with respect to your use of + # this software code. (c) 2006 Amazon Digital Services, Inc. or its + # affiliates. + +=head1 TESTING + +Testing S3 is a tricky thing. Amazon wants to charge you a bit of +money each time you use their service. And yes, testing counts as using. +Because of this, the application's test suite skips anything approaching +a real test unless you set these three environment variables: + +=over + +=item AMAZON_S3_EXPENSIVE_TESTS + +Doesn't matter what you set it to. Just has to be set + +=item AWS_ACCESS_KEY_ID + +Your AWS access key + +=item AWS_ACCESS_KEY_SECRET + +Your AWS sekkr1t passkey. Be forewarned that setting this environment variable +on a shared system might leak that information to another user. Be careful. + +=back + +=head1 AUTHOR + +Leon Brocard and unknown Amazon Digital Services programmers. + +Brad Fitzpatrick - return values, Bucket object + +=head1 SEE ALSO + +L + diff --git a/lib/Net/Amazon/S3/Bucket.pm b/lib/Net/Amazon/S3/Bucket.pm new file mode 100644 index 00000000..4ffab476 --- /dev/null +++ b/lib/Net/Amazon/S3/Bucket.pm @@ -0,0 +1,633 @@ +package Net::Amazon::S3::Bucket; +use Moose; +use MooseX::StrictConstructor; +use Carp; +use File::stat; +use IO::File; + +has 'account' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 ); +has 'bucket' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'creation_date' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); + +=head1 NAME + +Net::Amazon::S3::Bucket - convenience object for working with Amazon S3 buckets + +=head1 SYNOPSIS + + use Net::Amazon::S3; + + my $bucket = $s3->bucket("foo"); + + ok($bucket->add_key("key", "data")); + ok($bucket->add_key("key", "data", { + content_type => "text/html", + 'x-amz-meta-colour' => 'orange', + }); + + # the err and errstr methods just proxy up to the Net::Amazon::S3's + # objects err/errstr methods. + $bucket->add_key("bar", "baz") or + die $bucket->err . $bucket->errstr; + + # fetch a key + $val = $bucket->get_key("key"); + is( $val->{value}, 'data' ); + is( $val->{content_type}, 'text/html' ); + is( $val->{etag}, 'b9ece18c950afbfa6b0fdbfa4ff731d3' ); + is( $val->{'x-amz-meta-colour'}, 'orange' ); + + # returns undef on missing or on error (check $bucket->err) + is(undef, $bucket->get_key("non-existing-key")); + die $bucket->errstr if $bucket->err; + + # fetch a key's metadata + $val = $bucket->head_key("key"); + is( $val->{value}, '' ); + is( $val->{content_type}, 'text/html' ); + is( $val->{etag}, 'b9ece18c950afbfa6b0fdbfa4ff731d3' ); + is( $val->{'x-amz-meta-colour'}, 'orange' ); + + # delete a key + ok($bucket->delete_key($key_name)); + ok(! $bucket->delete_key("non-exist-key")); + + # delete the entire bucket (Amazon requires it first be empty) + $bucket->delete_bucket; + +=head1 DESCRIPTION + +This module represents an S3 bucket. You get a bucket object +from the Net::Amazon::S3 object. + +=head1 METHODS + +=head2 new + +Create a new bucket object. Expects a hash containing these two arguments: + +=over + +=item bucket + +=item account + +=back + +=cut + +sub _uri { + my ( $self, $key ) = @_; + return ($key) + ? $self->bucket . "/" . $self->account->_urlencode($key) + : $self->bucket . "/"; +} + +sub _conf_to_headers { + my ( $self, $conf ) = @_; + $conf = {} unless defined $conf; + $conf = {%$conf}; # clone it so as not to clobber the caller's copy + + if ( $conf->{acl_short} ) { + $self->account->_validate_acl_short( $conf->{acl_short} ); + $conf->{'x-amz-acl'} = $conf->{acl_short}; + delete $conf->{acl_short}; + } + + return $conf; +} + +=head2 add_key + +Takes three positional parameters: + +=over + +=item key + +=item value + +=item configuration + +A hash of configuration data for this key. (See synopsis); + +=back + +Returns a boolean. + +=cut + +# returns bool +sub add_key { + my ( $self, $key, $value, $conf ) = @_; + + if ( ref($value) eq 'SCALAR' ) { + $conf->{'Content-Length'} ||= -s $$value; + $value = _content_sub($$value); + } else { + $conf->{'Content-Length'} ||= length $value; + } + + my $acl_short; + if ( $conf->{acl_short} ) { + $acl_short = $conf->{acl_short}; + delete $conf->{acl_short}; + } + + my $http_request = Net::Amazon::S3::Request::PutObject->new( + s3 => $self->account, + bucket => $self->bucket, + key => $key, + value => $value, + acl_short => $acl_short, + headers => $conf, + )->http_request; + + # If we're pushing to a bucket that's under DNS flux, we might get a 307 + # Since LWP doesn't support actually waiting for a 100 Continue response, + # we'll just send a HEAD first to see what's going on + + if ( ref($value) ) { + return $self->account->_send_request_expect_nothing_probed($http_request); + } else { + return $self->account->_send_request_expect_nothing($http_request); + } +} + +=head2 add_key_filename + +Use this to upload a large file to S3. Takes three positional parameters: + +=over + +=item key + +=item filename + +=item configuration + +A hash of configuration data for this key. (See synopsis); + +=back + +Returns a boolean. + +=cut + +sub add_key_filename { + my ( $self, $key, $value, $conf ) = @_; + return $self->add_key( $key, \$value, $conf ); +} + +=head2 copy_key + +Creates (or replaces) a key, copying its contents from another key elsewhere in S3. +Takes the following parameters: + +=over + +=item key + +The key to (over)write + +=item source + +Where to copy the key from. Should be in the form C/I>/. + +=item conf + +Optional configuration hash. If present and defined, the configuration (ACL +and headers) there will be used for the new key; otherwise it will be copied +from the source key. + +=back + +=cut + +sub copy_key { + my ( $self, $key, $source, $conf ) = @_; + + my $acl_short; + if ( defined $conf ) { + if ( $conf->{acl_short} ) { + $acl_short = $conf->{acl_short}; + delete $conf->{acl_short}; + } + $conf->{'x-amz-metadata-directive'} = 'REPLACE'; + } else { + $conf = {}; + } + + $conf->{'x-amz-copy-source'} = $source; + + my $acct = $self->account; + my $http_request = Net::Amazon::S3::Request::PutObject->new( + s3 => $self->account, + bucket => $self->bucket, + key => $key, + value => '', + acl_short => $acl_short, + headers => $conf, + )->http_request; + + my $response = $acct->_do_http( $http_request ); + my $xpc = $acct->_xpc_of_content( $response->content ); + + if ( !$response->is_success || !$xpc || $xpc->findnodes("//Error") ) { + $acct->_remember_errors( $response->content ); + return 0; + } + + return 1; +} + +=head2 edit_metadata + +Changes the metadata associated with an existing key. Arguments: + +=over + +=item key + +The key to edit + +=item conf + +The new configuration hash to use + +=back + +=cut + +sub edit_metadata { + my ( $self, $key, $conf ) = @_; + croak "Need configuration hash" unless defined $conf; + + return $self->copy_key( $key, "/" . $self->bucket . "/" . $key, $conf ); +} + +=head2 head_key KEY + +Takes the name of a key in this bucket and returns its configuration hash + +=cut + +sub head_key { + my ( $self, $key ) = @_; + return $self->get_key( $key, "HEAD" ); +} + +=head2 get_key $key_name [$method] + +Takes a key name and an optional HTTP method (which defaults to C. +Fetches the key from AWS. + +On failure: + +Returns undef on missing content, throws an exception (dies) on server errors. + +On success: + +Returns a hashref of { content_type, etag, value, @meta } on success. Other +values from the server are there too, with the key being lowercased. + +=cut + +sub get_key { + my ( $self, $key, $method, $filename ) = @_; + $filename = $$filename if ref $filename; + my $acct = $self->account; + + my $http_request = Net::Amazon::S3::Request::GetObject->new( + s3 => $acct, + bucket => $self->bucket, + key => $key, + method => $method || 'GET', + )->http_request; + + my $response = $acct->_do_http( $http_request, $filename ); + + if ( $response->code == 404 ) { + return undef; + } + + $acct->_croak_if_response_error($response); + + my $etag = $response->header('ETag'); + if ($etag) { + $etag =~ s/^"//; + $etag =~ s/"$//; + } + + my $return; + foreach my $header ( $response->headers->header_field_names ) { + $return->{ lc $header } = $response->header($header); + } + $return->{content_length} = $response->content_length || 0; + $return->{content_type} = $response->content_type; + $return->{etag} = $etag; + $return->{value} = $response->content; + + return $return; + +} + +=head2 get_key_filename $key_name $method $filename + +Use this to download large files from S3. Takes a key name and an optional +HTTP method (which defaults to C. Fetches the key from AWS and writes +it to the filename. THe value returned will be empty. + +On failure: + +Returns undef on missing content, throws an exception (dies) on server errors. + +On success: + +Returns a hashref of { content_type, etag, value, @meta } on success + +=cut + +sub get_key_filename { + my ( $self, $key, $method, $filename ) = @_; + return $self->get_key( $key, $method, \$filename ); +} + +=head2 delete_key $key_name + +Removes C<$key> from the bucket. Forever. It's gone after this. + +Returns true on success and false on failure + +=cut + +# returns bool +sub delete_key { + my ( $self, $key ) = @_; + croak 'must specify key' unless defined $key && length $key; + + my $http_request = Net::Amazon::S3::Request::DeleteObject->new( + s3 => $self->account, + bucket => $self->bucket, + key => $key, + )->http_request; + + return $self->account->_send_request_expect_nothing($http_request); +} + +=head2 delete_bucket + +Delete the current bucket object from the server. Takes no arguments. + +Fails if the bucket has anything in it. + +This is an alias for C<$s3->delete_bucket($bucket)> + +=cut + +sub delete_bucket { + my $self = shift; + croak "Unexpected arguments" if @_; + return $self->account->delete_bucket($self); +} + +=head2 list + +List all keys in this bucket. + +see L for documentation of this method. + +=cut + +sub list { + my $self = shift; + my $conf = shift || {}; + $conf->{bucket} = $self->bucket; + return $self->account->list_bucket($conf); +} + +=head2 list_all + +List all keys in this bucket without having to worry about +'marker'. This may make multiple requests to S3 under the hood. + +see L for documentation of this method. + +=cut + +sub list_all { + my $self = shift; + my $conf = shift || {}; + $conf->{bucket} = $self->bucket; + return $self->account->list_bucket_all($conf); +} + +=head2 get_acl + +Takes one optional positional parameter + +=over + +=item key (optional) + +If no key is specified, it returns the acl for the bucket. + +=back + +Returns an acl in XML format. + +=cut + +sub get_acl { + my ( $self, $key ) = @_; + my $account = $self->account; + + my $http_request; + if ($key) { + $http_request = Net::Amazon::S3::Request::GetObjectAccessControl->new( + s3 => $account, + bucket => $self->bucket, + key => $key, + )->http_request; + } else { + $http_request = Net::Amazon::S3::Request::GetBucketAccessControl->new( + s3 => $account, + bucket => $self->bucket, + )->http_request; + } + + my $response = $account->_do_http($http_request); + + if ( $response->code == 404 ) { + return undef; + } + + $account->_croak_if_response_error($response); + + return $response->content; +} + +=head2 set_acl + +Takes a configuration hash_ref containing: + +=over + +=item acl_xml (cannot be used in conjuction with acl_short) + +An XML string which contains access control information which matches +Amazon's published schema. There is an example of one of these XML strings +in the tests for this module. + +=item acl_short (cannot be used in conjuction with acl_xml) + +You can use the shorthand notation instead of specifying XML for +certain 'canned' types of acls. + +(from the Amazon API documentation) + +private: Owner gets FULL_CONTROL. No one else has any access rights. +This is the default. + +public-read:Owner gets FULL_CONTROL and the anonymous principal is granted +READ access. If this policy is used on an object, it can be read from a +browser with no authentication. + +public-read-write:Owner gets FULL_CONTROL, the anonymous principal is +granted READ and WRITE access. This is a useful policy to apply to a bucket, +if you intend for any anonymous user to PUT objects into the bucket. + +authenticated-read:Owner gets FULL_CONTROL, and any principal authenticated +as a registered Amazon S3 user is granted READ access. + +=item key (optional) + +If the key is not set, it will apply the acl to the bucket. + +=back + +Returns a boolean. + +=cut + +sub set_acl { + my ( $self, $conf ) = @_; + $conf ||= {}; + + my $key = $conf->{key}; + my $http_request; + if ($key) { + $http_request = Net::Amazon::S3::Request::SetObjectAccessControl->new( + s3 => $self->account, + bucket => $self->bucket, + key => $key, + acl_short => $conf->{acl_short}, + acl_xml => $conf->{acl_xml}, + )->http_request; + } else { + $http_request = Net::Amazon::S3::Request::SetBucketAccessControl->new( + s3 => $self->account, + bucket => $self->bucket, + + acl_short => $conf->{acl_short}, + acl_xml => $conf->{acl_xml}, + )->http_request; + } + + return $self->account->_send_request_expect_nothing($http_request); + +} + +=head2 get_location_constraint + +Retrieves the location constraint set when the bucket was created. Returns a +string (eg, 'EU'), or undef if no location constraint was set. + +=cut + +sub get_location_constraint { + my ($self) = @_; + + my $http_request = Net::Amazon::S3::Request::GetBucketLocationConstraint->new( + s3 => $self->account, + bucket => $self->bucket, + )->http_request; + + my $xpc = $self->account->_send_request($http_request); + return undef unless $xpc && !$self->account->_remember_errors($xpc); + + my $lc = $xpc->findvalue("//s3:LocationConstraint"); + if ( defined $lc && $lc eq '' ) { + $lc = undef; + } + return $lc; +} + +# proxy up the err requests + +=head2 err + +The S3 error code for the last error the object ran into + +=cut + +sub err { $_[0]->account->err } + +=head2 errstr + +A human readable error string for the last error the object ran into + +=cut + +sub errstr { $_[0]->account->errstr } + +sub _content_sub { + my $filename = shift; + my $stat = stat($filename); + my $remaining = $stat->size; + my $blksize = $stat->blksize || 4096; + + croak "$filename not a readable file with fixed size" + unless -r $filename and ( -f _ || $remaining ); + my $fh = IO::File->new( $filename, 'r' ) + or croak "Could not open $filename: $!"; + $fh->binmode; + + return sub { + my $buffer; + + # upon retries the file is closed and we must reopen it + unless ( $fh->opened ) { + $fh = IO::File->new( $filename, 'r' ) + or croak "Could not open $filename: $!"; + $fh->binmode; + $remaining = $stat->size; + } + + # warn "read remaining $remaining"; + unless ( my $read = $fh->read( $buffer, $blksize ) ) { + +# warn "read $read buffer $buffer remaining $remaining"; + croak + "Error while reading upload content $filename ($remaining remaining) $!" + if $! and $remaining; + + # otherwise, we found EOF + $fh->close + or croak "close of upload content $filename failed: $!"; + $buffer ||= '' + ; # LWP expects an emptry string on finish, read returns 0 + } + $remaining -= length($buffer); + return $buffer; + }; +} + +1; + +__END__ + +=head1 SEE ALSO + +L + diff --git a/lib/Net/Amazon/S3/Client.pm b/lib/Net/Amazon/S3/Client.pm new file mode 100644 index 00000000..b97a074f --- /dev/null +++ b/lib/Net/Amazon/S3/Client.pm @@ -0,0 +1,199 @@ +package Net::Amazon::S3::Client; +use Moose; +use DateTime::Format::ISO8601; +use HTTP::Status qw(is_error status_message); +use MooseX::StrictConstructor; +use Moose::Util::TypeConstraints; + +type 'DateTime' => where { $_->isa('DateTime') }; +coerce 'DateTime' => from 'Str' => + via { DateTime::Format::ISO8601->parse_datetime($_) }; + +type 'Etag' => where { $_ =~ /^[a-z0-9]{32}$/ }; + +type 'OwnerId' => where { $_ =~ /^[a-z0-9]{64}$/ }; + +has 's3' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 ); + +sub buckets { + my $self = shift; + my $s3 = $self->s3; + + my $http_request + = Net::Amazon::S3::Request::ListAllMyBuckets->new( s3 => $s3 ) + ->http_request; + + my $xpc = $self->_send_request_xpc($http_request); + + my $owner_id + = $xpc->findvalue('/s3:ListAllMyBucketsResult/s3:Owner/s3:ID'); + my $owner_display_name = $xpc->findvalue( + '/s3:ListAllMyBucketsResult/s3:Owner/s3:DisplayName'); + + my @buckets; + foreach my $node ( + $xpc->findnodes('/s3:ListAllMyBucketsResult/s3:Buckets/s3:Bucket') ) + { + push @buckets, + Net::Amazon::S3::Client::Bucket->new( + { client => $self, + name => $xpc->findvalue( './s3:Name', $node ), + creation_date => + $xpc->findvalue( './s3:CreationDate', $node ), + owner_id => $owner_id, + owner_display_name => $owner_display_name, + } + ); + + } + return @buckets; +} + +sub create_bucket { + my ( $self, %conf ) = @_; + + my $bucket = Net::Amazon::S3::Client::Bucket->new( + client => $self, + name => $conf{name}, + ); + $bucket->_create( + acl_short => $conf{acl_short}, + location_constraint => $conf{location_constraint}, + ); + return $bucket; +} + +sub bucket { + my ( $self, %conf ) = @_; + return Net::Amazon::S3::Client::Bucket->new( + client => $self, + %conf, + ); +} + +sub _send_request { + my ( $self, $http_request, $filename ) = @_; + + my $http_response = $self->s3->ua->request( $http_request, $filename ); + + my $content = $http_response->content; + my $content_type = $http_response->content_type; + my $code = $http_response->code; + + if ( is_error($code) ) { + if ( $content_type eq 'application/xml' ) { + my $doc = $self->s3->libxml->parse_string($content); + my $xpc = XML::LibXML::XPathContext->new($doc); + $xpc->registerNs( 's3', + 'http://s3.amazonaws.com/doc/2006-03-01/' ); + + if ( $xpc->findnodes('/Error') ) { + my $code = $xpc->findvalue('/Error/Code'); + my $message = $xpc->findvalue('/Error/Message'); + confess("$code: $message"); + } else { + confess status_message($code); + } + } else { + confess status_message($code); + } + } + return $http_response; +} + +sub _send_request_content { + my ( $self, $http_request, $filename ) = @_; + my $http_response = $self->_send_request( $http_request, $filename ); + return $http_response->content; +} + +sub _send_request_xpc { + my ( $self, $http_request, $filename ) = @_; + my $http_response = $self->_send_request( $http_request, $filename ); + + my $doc = $self->s3->libxml->parse_string( $http_response->content ); + my $xpc = XML::LibXML::XPathContext->new($doc); + $xpc->registerNs( 's3', 'http://s3.amazonaws.com/doc/2006-03-01/' ); + + return $xpc; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Client - An easy-to-use Amazon S3 client + +=head1 SYNOPSIS + + my $s3 = Net::Amazon::S3->new( + aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + ); + my $client = Net::Amazon::S3::Client->new( s3 => $s3 ); + + # list all my buckets + # returns a list of L objects + my @buckets = $client->buckets; + foreach my $bucket (@buckets) { + print $bucket->name . "\n"; + } + + # create a new bucket + # returns a L object + my $bucket = $client->create_bucket( + name => $bucket_name, + acl_short => 'private', + location_constraint => 'US', + ); + + # or use an existing bucket + # returns a L object + my $bucket = $client->bucket( name => $bucket_name ); + +=head1 DESCRIPTION + +The L module was written when the Amazon S3 service +had just come out and it is a light wrapper around the APIs. Some +bad API decisions were also made. The +L, L and +L classes are designed after years +of usage to be easy to use for common tasks. + +These classes throw an exception when a fatal error occurs. It +also is very careful to pass an MD5 of the content when uploaded +to S3 and check the resultant ETag. + +WARNING: This is an early release of the Client classes, the APIs +may change. + +=head1 METHODS + +=head2 buckets + + # list all my buckets + # returns a list of L objects + my @buckets = $client->buckets; + foreach my $bucket (@buckets) { + print $bucket->name . "\n"; + } + +=head2 create_bucket + + # create a new bucket + # returns a L object + my $bucket = $client->create_bucket( + name => $bucket_name, + acl_short => 'private', + location_constraint => 'US', + ); + +=head2 bucket + + # or use an existing bucket + # returns a L object + my $bucket = $client->bucket( name => $bucket_name ); + diff --git a/lib/Net/Amazon/S3/Client/Bucket.pm b/lib/Net/Amazon/S3/Client/Bucket.pm new file mode 100644 index 00000000..10dad786 --- /dev/null +++ b/lib/Net/Amazon/S3/Client/Bucket.pm @@ -0,0 +1,217 @@ +package Net::Amazon::S3::Client::Bucket; +use Moose; +use MooseX::StrictConstructor; +use Data::Stream::Bulk::Callback; + +has 'client' => + ( is => 'ro', isa => 'Net::Amazon::S3::Client', required => 1 ); +has 'name' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'creation_date' => + ( is => 'ro', isa => 'DateTime', coerce => 1, required => 0 ); +has 'owner_id' => ( is => 'ro', isa => 'OwnerId', required => 0 ); +has 'owner_display_name' => ( is => 'ro', isa => 'Str', required => 0 ); + +sub _create { + my ( $self, %conf ) = @_; + + my $http_request = Net::Amazon::S3::Request::CreateBucket->new( + s3 => $self->client->s3, + bucket => $self->name, + acl_short => $conf{acl_short}, + location_constraint => $conf{location_constraint}, + )->http_request; + + $self->client->_send_request($http_request); +} + +sub delete { + my $self = shift; + my $http_request = Net::Amazon::S3::Request::DeleteBucket->new( + s3 => $self->client->s3, + bucket => $self->name, + )->http_request; + + $self->client->_send_request($http_request); +} + +sub acl { + my $self = shift; + + my $http_request = Net::Amazon::S3::Request::GetBucketAccessControl->new( + s3 => $self->client->s3, + bucket => $self->name, + )->http_request; + + return $self->client->_send_request_content($http_request); +} + +sub location_constraint { + my $self = shift; + + my $http_request + = Net::Amazon::S3::Request::GetBucketLocationConstraint->new( + s3 => $self->client->s3, + bucket => $self->name, + )->http_request; + + my $xpc = $self->client->_send_request_xpc($http_request); + + my $lc = $xpc->findvalue('/s3:LocationConstraint'); + if ( defined $lc && $lc eq '' ) { + $lc = 'US'; + } + return $lc; +} + +sub list { + my $self = shift; + + my $marker = undef; + my $end = 0; + + return Data::Stream::Bulk::Callback->new( + callback => sub { + + return undef if $end; + + my $http_request = Net::Amazon::S3::Request::ListBucket->new( + s3 => $self->client->s3, + bucket => $self->name, + marker => $marker, + )->http_request; + + my $xpc = $self->client->_send_request_xpc($http_request); + + my @objects; + foreach my $node ( + $xpc->findnodes('/s3:ListBucketResult/s3:Contents') ) + { + my $etag = $xpc->findvalue( "./s3:ETag", $node ); + $etag =~ s/^"//; + $etag =~ s/"$//; + + # storage_class => $xpc->findvalue( ".//s3:StorageClass", $node ), + # owner_id => $xpc->findvalue( ".//s3:ID", $node ), + # owner_displayname => + # $xpc->findvalue( ".//s3:DisplayName", $node ), + + push @objects, + Net::Amazon::S3::Client::Object->new( + client => $self->client, + bucket => $self, + key => $xpc->findvalue( './s3:Key', $node ), + last_modified => + $xpc->findvalue( './s3:LastModified', $node ), + etag => $etag, + size => $xpc->findvalue( './s3:Size', $node ), + ); + } + + return undef unless @objects; + + my $is_truncated + = scalar $xpc->findvalue( + '/s3:ListBucketResult/s3:IsTruncated') eq 'true' + ? 1 + : 0; + $end = 1 unless $is_truncated; + + $marker = $xpc->findvalue('/s3:ListBucketResult/s3:NextMarker') + || $objects[-1]->key; + + return \@objects; + } + ); +} + +sub object { + my ( $self, %conf ) = @_; + return Net::Amazon::S3::Client::Object->new( + client => $self->client, + bucket => $self, + %conf, + ); +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Client::Bucket - An easy-to-use Amazon S3 client bucket + +=head1 SYNOPSIS + + # return the bucket name + print $bucket->name . "\n"; + + # return the bucket location constraint + print "Bucket is in the " . $bucket->location_constraint . "\n"; + + # return the ACL XML + my $acl = $bucket->acl; + + # list objects in the bucket + # this returns a L object which returns a + # stream of L objects, as it may + # have to issue multiple API requests + my $stream = $bucket->list; + until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + ... + } + } + + # returns a L, which can then + # be used to get or put + my $object = $bucket->object( key => 'this is the key' ); + + # delete the bucket (it must be empty) + $bucket->delete; + +=head1 DESCRIPTION + +This module represents buckets. + +=head1 METHODS + +=head2 acl + + # return the ACL XML + my $acl = $bucket->acl; + +=head2 delete + + # delete the bucket (it must be empty) + $bucket->delete; + +=head2 list + + # list objects in the bucket + # this returns a L object which returns a + # stream of L objects, as it may + # have to issue multiple API requests + my $stream = $bucket->list; + until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + ... + } + } + +=head2 location_constraint + + # return the bucket location constraint + print "Bucket is in the " . $bucket->location_constraint . "\n"; + +=head2 name + + # return the bucket name + print $bucket->name . "\n"; + +=head2 object + + # returns a L, which can then + # be used to get or put + my $object = $bucket->object( key => 'this is the key' ); + diff --git a/lib/Net/Amazon/S3/Client/Object.pm b/lib/Net/Amazon/S3/Client/Object.pm new file mode 100644 index 00000000..5a2461c7 --- /dev/null +++ b/lib/Net/Amazon/S3/Client/Object.pm @@ -0,0 +1,361 @@ +package Net::Amazon::S3::Client::Object; +use Moose; +use MooseX::StrictConstructor; +use DateTime::Format::ISO8601; +use Digest::MD5 qw(md5 md5_hex); +use Digest::MD5::File qw(file_md5 file_md5_hex); +use File::stat; +use MIME::Base64; +use Moose::Util::TypeConstraints; + +enum 'AclShort' => + qw(private public-read public-read-write authenticated-read); + +has 'client' => + ( is => 'ro', isa => 'Net::Amazon::S3::Client', required => 1 ); +has 'bucket' => + ( is => 'ro', isa => 'Net::Amazon::S3::Client::Bucket', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'etag' => ( is => 'ro', isa => 'Etag', required => 0 ); +has 'size' => ( is => 'ro', isa => 'Int', required => 0 ); +has 'last_modified' => + ( is => 'ro', isa => 'DateTime', coerce => 1, required => 0 ); +has 'acl_short' => + ( is => 'ro', isa => 'AclShort', required => 0, default => 'private' ); +has 'content_type' => ( + is => 'ro', + isa => 'Str', + required => 0, + default => 'binary/octet-stream' +); + +sub get { + my $self = shift; + + my $http_request = Net::Amazon::S3::Request::GetObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + method => 'GET', + )->http_request; + + my $http_response = $self->client->_send_request($http_request); + my $content = $http_response->content; + + my $md5_hex = md5_hex($content); + + if ( $self->etag ) { + confess 'Corrupted download' if $self->etag ne $md5_hex; + } else { + confess 'Corrupted download' + if $self->_etag($http_response) ne $md5_hex; + } + return $content; +} + +sub get_filename { + my ( $self, $filename ) = @_; + + my $http_request = Net::Amazon::S3::Request::GetObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + method => 'GET', + )->http_request; + + my $http_response + = $self->client->_send_request( $http_request, $filename ); + + my $md5_hex = file_md5_hex($filename); + + if ( $self->etag ) { + confess 'Corrupted download' if $self->etag ne $md5_hex; + } else { + confess 'Corrupted download' + if $self->_etag($http_response) ne $md5_hex; + } +} + +sub put { + my ( $self, $value ) = @_; + my $md5 = md5($value); + my $md5_hex = unpack( 'H*', $md5 ); + my $md5_base64 = encode_base64($md5); + chomp $md5_base64; + + my $conf = { + 'Content-MD5' => $md5_base64, + 'Content-Length' => length $value, + 'Content-Type' => $self->content_type, + }; + + my $http_request = Net::Amazon::S3::Request::PutObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + value => $value, + headers => $conf, + acl_short => $self->acl_short, + )->http_request; + + my $http_response = $self->client->_send_request($http_request); + + confess 'Error uploading' if $http_response->code != 200; + + my $etag = $self->_etag($http_response); + + confess 'Corrupted upload' if $etag ne $md5_hex; +} + +sub put_filename { + my ( $self, $filename ) = @_; + + my $md5_hex = $self->etag || file_md5_hex($filename); + my $size = $self->size; + unless ($size) { + my $stat = stat($filename) || confess("No $filename: $!"); + $size = $stat->size; + } + + my $md5 = pack( 'H*', $md5_hex ); + my $md5_base64 = encode_base64($md5); + chomp $md5_base64; + + my $conf = { + 'Content-MD5' => $md5_base64, + 'Content-Length' => $size, + 'Content-Type' => $self->content_type, + }; + + my $http_request = Net::Amazon::S3::Request::PutObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + value => $self->_content_sub($filename), + headers => $conf, + acl_short => $self->acl_short, + )->http_request; + + my $http_response = $self->client->_send_request($http_request); + + confess 'Error uploading' . $http_response->as_string + if $http_response->code != 200; + + confess 'Corrupted upload' if $self->_etag($http_response) ne $md5_hex; +} + +sub delete { + my $self = shift; + + my $http_request = Net::Amazon::S3::Request::DeleteObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + )->http_request; + + $self->client->_send_request($http_request); +} + +sub uri { + my $self = shift; + return Net::Amazon::S3::Request::GetObject->new( + s3 => $self->client->s3, + bucket => $self->bucket->name, + key => $self->key, + method => 'GET', + )->http_request->uri; +} + +sub _content_sub { + my $self = shift; + my $filename = shift; + my $stat = stat($filename); + my $remaining = $stat->size; + my $blksize = $stat->blksize || 4096; + + confess "$filename not a readable file with fixed size" + unless -r $filename and ( -f _ || $remaining ); + my $fh = IO::File->new( $filename, 'r' ) + or confess "Could not open $filename: $!"; + $fh->binmode; + + return sub { + my $buffer; + + # upon retries the file is closed and we must reopen it + unless ( $fh->opened ) { + $fh = IO::File->new( $filename, 'r' ) + or confess "Could not open $filename: $!"; + $fh->binmode; + $remaining = $stat->size; + } + + # warn "read remaining $remaining"; + unless ( my $read = $fh->read( $buffer, $blksize ) ) { + +# warn "read $read buffer $buffer remaining $remaining"; + confess + "Error while reading upload content $filename ($remaining remaining) $!" + if $! and $remaining; + + # otherwise, we found EOF + $fh->close + or confess "close of upload content $filename failed: $!"; + $buffer ||= '' + ; # LWP expects an emptry string on finish, read returns 0 + } + $remaining -= length($buffer); + return $buffer; + }; +} + +sub _etag { + my ( $self, $http_response ) = @_; + my $etag = $http_response->header('ETag'); + if ($etag) { + $etag =~ s/^"//; + $etag =~ s/"$//; + } + return $etag; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Client::Object - An easy-to-use Amazon S3 client object + +=head1 SYNOPSIS + + # show the key + print $object->key . "\n"; + + # show the etag of an existing object (if fetched by listing + # a bucket) + print $object->etag . "\n"; + + # show the size of an existing object (if fetched by listing + # a bucket) + print $object->size . "\n"; + + # to create a new object + my $object = $bucket->object( key => 'this is the key' ); + $object->put('this is the value'); + + # to get the vaue of an object + my $value = $object->get; + + # to delete an object + $object->delete; + + # to create a new object which is publically-accessible with a + # content-type of text/plain + my $object = $bucket->object( + key => 'this is the public key', + acl_short => 'public-read', + content_type => 'text/plain', + ); + $object->put('this is the public value'); + + # return the URI of a publically-accessible object + my $uri = $object->uri; + + # upload a file + my $object = $bucket->object( + key => 'images/my_hat.jpg', + content_type => 'image/jpeg', + ); + $object->put_filename('hat.jpg'); + + # upload a file if you already know its md5_hex and size + my $object = $bucket->object( + key => 'images/my_hat.jpg', + content_type => 'image/jpeg', + etag => $md5_hex, + size => $size, + ); + $object->put_filename('hat.jpg'); + + # download the value of the object into a file + my $object = $bucket->object( key => 'images/my_hat.jpg' ); + $object->get_filename('hat_backup.jpg'); + +=head1 DESCRIPTION + +This module represents objects in buckets. + +=head1 METHODS + +=head2 etag + + # show the etag of an existing object (if fetched by listing + # a bucket) + print $object->etag . "\n"; + +=head2 delete + + # to delete an object + $object->delete; + +=head2 get + + # to get the vaue of an object + my $value = $object->get; + +=head2 get_filename + + # download the value of the object into a file + my $object = $bucket->object( key => 'images/my_hat.jpg' ); + $object->get_filename('hat_backup.jpg'); + +=head2 key + + # show the key + print $object->key . "\n"; + +=head2 put + + # to create a new object + my $object = $bucket->object( key => 'this is the key' ); + $object->put('this is the value'); + + # to create a new object which is publically-accessible with a + # content-type of text/plain + my $object = $bucket->object( + key => 'this is the public key', + acl_short => 'public-read', + content_type => 'text/plain', + ); + $object->put('this is the public value'); + +=head2 put_filename + + # upload a file + my $object = $bucket->object( + key => 'images/my_hat.jpg', + content_type => 'image/jpeg', + ); + $object->put_filename('hat.jpg'); + + # upload a file if you already know its md5_hex and size + my $object = $bucket->object( + key => 'images/my_hat.jpg', + content_type => 'image/jpeg', + etag => $md5_hex, + size => $size, + ); + $object->put_filename('hat.jpg'); + +=head2 size + + # show the size of an existing object (if fetched by listing + # a bucket) + print $object->size . "\n"; + +=head2 uri + + # return the URI of a publically-accessible object + my $uri = $object->uri; + diff --git a/lib/Net/Amazon/S3/HTTPRequest.pm b/lib/Net/Amazon/S3/HTTPRequest.pm new file mode 100644 index 00000000..2fb7b7d4 --- /dev/null +++ b/lib/Net/Amazon/S3/HTTPRequest.pm @@ -0,0 +1,214 @@ +package Net::Amazon::S3::HTTPRequest; +use Moose; +use MooseX::StrictConstructor; +use HTTP::Date; +use MIME::Base64 qw(encode_base64); +use Moose::Util::TypeConstraints; +my $METADATA_PREFIX = 'x-amz-meta-'; +my $AMAZON_HEADER_PREFIX = 'x-amz-'; + +enum 'HTTPMethod' => qw(DELETE GET HEAD PUT); + +has 's3' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 ); +has 'method' => ( is => 'ro', isa => 'HTTPMethod', required => 1 ); +has 'path' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'headers' => + ( is => 'ro', isa => 'HashRef', required => 0, default => sub { {} } ); +has 'content' => + ( is => 'ro', isa => 'Str|CodeRef', required => 0, default => '' ); +has 'metadata' => + ( is => 'ro', isa => 'HashRef', required => 0, default => sub { {} } ); + +# make the HTTP::Request object +sub http_request { + my $self = shift; + my $method = $self->method; + my $path = $self->path; + my $headers = $self->headers; + my $content = $self->content; + my $metadata = $self->metadata; + + my $http_headers = $self->_merge_meta( $headers, $metadata ); + + $self->_add_auth_header( $http_headers, $method, $path ) + unless exists $headers->{Authorization}; + my $protocol = $self->s3->secure ? 'https' : 'http'; + my $uri = "$protocol://s3.amazonaws.com/$path"; + if ( $path =~ m{^([^/?]+)(.*)} && _is_dns_bucket($1) ) { + $uri = "$protocol://$1.s3.amazonaws.com$2"; + } + + my $request + = HTTP::Request->new( $method, $uri, $http_headers, $content ); + + # 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; +} + +sub _add_auth_header { + my ( $self, $headers, $method, $path ) = @_; + my $aws_access_key_id = $self->s3->aws_access_key_id; + my $aws_secret_access_key = $self->s3->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" ); +} + +# 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} = $self->_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"; + } + } + + # 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; + } +} + +# 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]; + + 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; +} + +# 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; +} + +sub _trim { + my ( $self, $value ) = @_; + $value =~ s/^\s+//; + $value =~ s/\s+$//; + return $value; +} + +sub _urlencode { + my ( $self, $unencoded ) = @_; + return uri_escape_utf8( $unencoded, '^A-Za-z0-9_-' ); +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::HTTPRequest - Create a signed HTTP::Request + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'PUT', + path => $self->bucket . '/', + headers => $headers, + content => $content, + )->http_request; + +=head1 DESCRIPTION + +This module creates an HTTP::Request object that is signed +appropriately for Amazon S3. + +=head1 METHODS + +=head2 http_request + +This method creates, signs and returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request.pm b/lib/Net/Amazon/S3/Request.pm new file mode 100644 index 00000000..316e1f84 --- /dev/null +++ b/lib/Net/Amazon/S3/Request.pm @@ -0,0 +1,65 @@ +package Net::Amazon::S3::Request; +use Moose; +use MooseX::StrictConstructor; +use Moose::Util::TypeConstraints; +use Regexp::Common qw /net/; + +enum 'AclShort' => + qw(private public-read public-read-write authenticated-read); +enum 'LocationConstraint' => ( 'US', 'EU' ); + +# To comply with Amazon S3 requirements, bucket names must: +# Contain lowercase letters, numbers, periods (.), underscores (_), and dashes (-) +# Start with a number or letter +# Be between 3 and 255 characters long +# Not be in an IP address style (e.g., "192.168.5.4") + +subtype 'BucketName1' => as 'Str' => where { + $_ =~ /^[a-z0-9._-]+$/; +} => message { + "Bucket name ($_) must contain lowercase letters, numbers, periods (.), underscores (_), and dashes (-)"; +}; + +subtype 'BucketName2' => as 'BucketName1' => where { + $_ =~ /^[a-z0-9]/; +} => message { + "Bucket name ($_) must start with a number or letter"; +}; + +subtype 'BucketName3' => as 'BucketName2' => where { + length($_) >= 3 && length($_) <= 255; +} => message { + "Bucket name ($_) must be between 3 and 255 characters long"; +}; + +subtype 'BucketName' => as 'BucketName3' => where { + $_ !~ /^$RE{net}{IPv4}$/; +} => message { + "Bucket name ($_) must not be in an IP address style (e.g., '192.168.5.4')"; +}; + +has 's3' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 ); + +sub _uri { + my ( $self, $key ) = @_; + return ($key) + ? $self->bucket . "/" . $self->s3->_urlencode($key) + : $self->bucket . "/"; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request - Base class for request objects + +=head1 SYNOPSIS + + # do not instantiate directly + +=head1 DESCRIPTION + +This module is a base class for all the Net::Amazon::S3::Request::* +classes. diff --git a/lib/Net/Amazon/S3/Request/CreateBucket.pm b/lib/Net/Amazon/S3/Request/CreateBucket.pm new file mode 100644 index 00000000..300e2a07 --- /dev/null +++ b/lib/Net/Amazon/S3/Request/CreateBucket.pm @@ -0,0 +1,63 @@ +package Net::Amazon::S3::Request::CreateBucket; +use Moose; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'acl_short' => ( is => 'ro', isa => 'Maybe[AclShort]', required => 0 ); +has 'location_constraint' => + ( is => 'ro', isa => 'Maybe[LocationConstraint]', required => 0 ); + +sub http_request { + my $self = shift; + + my $headers + = ( $self->acl_short ) + ? { 'x-amz-acl' => $self->acl_short } + : {}; + + my $content = ''; + if ( defined $self->location_constraint + && $self->location_constraint eq 'EU' ) + { + $content + = "" + . $self->location_constraint + . ""; + } + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'PUT', + path => $self->bucket . '/', + headers => $headers, + content => $content, + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::CreateBucket - An internal class to create a bucket + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::CreateBucket->new( + s3 => $s3, + bucket => $bucket, + acl_short => $acl_short, + location_constraint => $location_constraint, + )->http_request; + +=head1 DESCRIPTION + +This module creates a bucket. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/DeleteBucket.pm b/lib/Net/Amazon/S3/Request/DeleteBucket.pm new file mode 100644 index 00000000..139aee45 --- /dev/null +++ b/lib/Net/Amazon/S3/Request/DeleteBucket.pm @@ -0,0 +1,41 @@ +package Net::Amazon::S3::Request::DeleteBucket; +use Moose; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'DELETE', + path => $self->bucket . '/', + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::DeleteBucket - An internal class to delete a bucket + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::DeleteBucket->new( + s3 => $s3, + bucket => $bucket, + )->http_request; + +=head1 DESCRIPTION + +This module deletes a bucket. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/DeleteObject.pm b/lib/Net/Amazon/S3/Request/DeleteObject.pm new file mode 100644 index 00000000..9a120fe1 --- /dev/null +++ b/lib/Net/Amazon/S3/Request/DeleteObject.pm @@ -0,0 +1,44 @@ +package Net::Amazon::S3::Request::DeleteObject; +use Moose; +use Moose::Util::TypeConstraints; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'DELETE', + path => $self->_uri( $self->key ), + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::DeleteObject - An internal class to delete an object + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::DeleteObject->new( + s3 => $s3, + bucket => $bucket, + key => $key, + )->http_request; + +=head1 DESCRIPTION + +This module deletes an object. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm b/lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm new file mode 100644 index 00000000..9ebdc02b --- /dev/null +++ b/lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm @@ -0,0 +1,42 @@ +package Net::Amazon::S3::Request::GetBucketAccessControl; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'GET', + path => $self->_uri('') . '?acl', + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::GetBucketAccessControl - An internal class to get a bucket's access control + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::GetBucketAccessControl->new( + s3 => $s3, + bucket => $bucket, + )->http_request; + +=head1 DESCRIPTION + +This module gets a bucket's access control. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm b/lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm new file mode 100644 index 00000000..047135af --- /dev/null +++ b/lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm @@ -0,0 +1,42 @@ +package Net::Amazon::S3::Request::GetBucketLocationConstraint; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'GET', + path => $self->_uri('') . '?location', + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::GetBucketLocationConstraint - An internal class to get a bucket's location constraint + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::GetBucketLocationConstraint->new( + s3 => $s3, + bucket => $bucket, + )->http_request; + +=head1 DESCRIPTION + +This module gets a bucket's location constraint. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/GetObject.pm b/lib/Net/Amazon/S3/Request/GetObject.pm new file mode 100644 index 00000000..e669dd41 --- /dev/null +++ b/lib/Net/Amazon/S3/Request/GetObject.pm @@ -0,0 +1,46 @@ +package Net::Amazon::S3::Request::GetObject; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'method' => ( is => 'ro', isa => 'HTTPMethod', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => $self->method, + path => $self->_uri( $self->key ), + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::GetObject - An internal class to get an object + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::GetObject->new( + s3 => $s3, + bucket => $bucket, + key => $key, + method => 'GET', + )->http_request; + +=head1 DESCRIPTION + +This module gets an object. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm b/lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm new file mode 100644 index 00000000..29fc584e --- /dev/null +++ b/lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm @@ -0,0 +1,44 @@ +package Net::Amazon::S3::Request::GetObjectAccessControl; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); + +sub http_request { + my $self = shift; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'GET', + path => $self->_uri($self->key) . '?acl', + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::GetObjectAccessControl - An internal class to get an object's access control + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::GetObjectAccessControl->new( + s3 => $s3, + bucket => $bucket, + key => $key, + )->http_request; + +=head1 DESCRIPTION + +This module gets an object's access control. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm b/lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm new file mode 100644 index 00000000..09dd2caf --- /dev/null +++ b/lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm @@ -0,0 +1,38 @@ +package Net::Amazon::S3::Request::ListAllMyBuckets; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +sub http_request { + my $self = shift; + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'GET', + path => '', + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::ListAllMyBuckets - An internal class to list all buckets + +=head1 SYNOPSIS + + my $http_request + = Net::Amazon::S3::Request::ListAllMyBuckets->new( s3 => $s3 ) + ->http_request; + +=head1 DESCRIPTION + +This module lists all buckets. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/ListBucket.pm b/lib/Net/Amazon/S3/Request/ListBucket.pm new file mode 100644 index 00000000..1d5262b0 --- /dev/null +++ b/lib/Net/Amazon/S3/Request/ListBucket.pm @@ -0,0 +1,68 @@ +package Net::Amazon::S3::Request::ListBucket; +use Moose; +use MooseX::StrictConstructor; +use URI::Escape qw(uri_escape_utf8); +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'prefix' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); +has 'delimiter' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); +has 'max_keys' => + ( is => 'ro', isa => 'Maybe[Int]', required => 0, default => 1000 ); +has 'marker' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); + +sub http_request { + my $self = shift; + + my $path = $self->bucket . "/"; + + my @post; + foreach my $method qw(prefix delimiter max_keys marker) { + my $value = $self->$method; + next unless $value; + push @post, $method . "=" . $self->_urlencode($value); + } + if (@post) { + $path .= '?' . join( '&', @post ); + } + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'GET', + path => $path, + )->http_request; +} + +sub _urlencode { + my ( $self, $unencoded ) = @_; + return uri_escape_utf8( $unencoded, '^A-Za-z0-9_-' ); +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::ListBucket - An internal class to list a bucket + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::ListBucket->new( + s3 => $s3, + bucket => $bucket, + delimiter => $delimiter, + max_keys => $max_keys, + marker => $marker, + )->http_request; + +=head1 DESCRIPTION + +This module lists a bucket. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/PutObject.pm b/lib/Net/Amazon/S3/Request/PutObject.pm new file mode 100644 index 00000000..cf757fbb --- /dev/null +++ b/lib/Net/Amazon/S3/Request/PutObject.pm @@ -0,0 +1,58 @@ +package Net::Amazon::S3::Request::PutObject; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'value' => ( is => 'ro', isa => 'Str|CodeRef', required => 1 ); +has 'acl_short' => ( is => 'ro', isa => 'Maybe[AclShort]', required => 0 ); +has 'headers' => + ( is => 'ro', isa => 'HashRef', required => 0, default => sub { {} } ); + +sub http_request { + my $self = shift; + my $headers = $self->headers; + + if ( $self->acl_short ) { + $headers->{'x-amz-acl'} = $self->acl_short; + } + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'PUT', + path => $self->_uri( $self->key ), + headers => $self->headers, + content => $self->value, + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::PutObject - An internal class to put an object + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::PutObject->new( + s3 => $s3, + bucket => $bucket, + key => $key, + value => $value, + acl_short => $acl_short, + headers => $conf, + )->http_request; + +=head1 DESCRIPTION + +This module puts an object. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm b/lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm new file mode 100644 index 00000000..93a96dfa --- /dev/null +++ b/lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm @@ -0,0 +1,62 @@ +package Net::Amazon::S3::Request::SetBucketAccessControl; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'acl_short' => ( is => 'ro', isa => 'Maybe[AclShort]', required => 0 ); +has 'acl_xml' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); + +sub http_request { + my $self = shift; + + unless ( $self->acl_xml || $self->acl_short ) { + confess "need either acl_xml or acl_short"; + } + + if ( $self->acl_xml && $self->acl_short ) { + confess "can not provide both acl_xml and acl_short"; + } + + my $headers + = ( $self->acl_short ) + ? { 'x-amz-acl' => $self->acl_short } + : {}; + my $xml = $self->acl_xml || ''; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'PUT', + path => $self->_uri('') . '?acl', + headers => $headers, + content => $xml, + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::SetBucketAccessControl - An internal class to set a bucket's access control + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::SetBucketAccessControl->new( + s3 => $s3, + bucket => $bucket, + acl_short => $acl_short, + acl_xml => $acl_xml, + )->http_request; + +=head1 DESCRIPTION + +This module sets a bucket's access control. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm b/lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm new file mode 100644 index 00000000..ab64fe4d --- /dev/null +++ b/lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm @@ -0,0 +1,64 @@ +package Net::Amazon::S3::Request::SetObjectAccessControl; +use Moose; +use MooseX::StrictConstructor; +extends 'Net::Amazon::S3::Request'; + +has 'bucket' => ( is => 'ro', isa => 'BucketName', required => 1 ); +has 'key' => ( is => 'ro', isa => 'Str', required => 1 ); +has 'acl_short' => ( is => 'ro', isa => 'Maybe[AclShort]', required => 0 ); +has 'acl_xml' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); + +sub http_request { + my $self = shift; + + unless ( $self->acl_xml || $self->acl_short ) { + confess "need either acl_xml or acl_short"; + } + + if ( $self->acl_xml && $self->acl_short ) { + confess "can not provide both acl_xml and acl_short"; + } + + my $headers + = ( $self->acl_short ) + ? { 'x-amz-acl' => $self->acl_short } + : {}; + my $xml = $self->acl_xml || ''; + + return Net::Amazon::S3::HTTPRequest->new( + s3 => $self->s3, + method => 'PUT', + path => $self->_uri( $self->key ) . '?acl', + headers => $headers, + content => $xml, + )->http_request; +} + +1; + +__END__ + +=head1 NAME + +Net::Amazon::S3::Request::SetObjectAccessControl - An internal class to set an object's access control + +=head1 SYNOPSIS + + my $http_request = Net::Amazon::S3::Request::SetObjectAccessControl->new( + s3 => $s3, + bucket => $bucket, + key => $key, + acl_short => $acl_short, + acl_xml => $acl_xml, + )->http_request; + +=head1 DESCRIPTION + +This module sets an object's access control. + +=head1 METHODS + +=head2 http_request + +This method returns a HTTP::Request object. + diff --git a/t/01api.t b/t/01api.t new file mode 100644 index 00000000..ce30f276 --- /dev/null +++ b/t/01api.t @@ -0,0 +1,379 @@ +#!perl +use warnings; +use strict; +use lib 'lib'; +use Digest::MD5::File qw(file_md5_hex); +use Test::More; + +unless ( $ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) { + plan skip_all => 'Testing this module for real costs money.'; +} else { + plan tests => 71 * 2 + 4; +} + +use_ok('Net::Amazon::S3'); + +use vars qw/$OWNER_ID $OWNER_DISPLAYNAME/; + +my $aws_access_key_id = $ENV{'AWS_ACCESS_KEY_ID'}; +my $aws_secret_access_key = $ENV{'AWS_ACCESS_KEY_SECRET'}; + +my $s3 = Net::Amazon::S3->new( + { aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + } +); + +# list all buckets that i own +my $response = $s3->buckets; + +$OWNER_ID = $response->{owner_id}; +$OWNER_DISPLAYNAME = $response->{owner_displayname}; + +TODO: { + local $TODO = "These tests only work if you're leon"; + + like( $response->{owner_id}, qr/^46a801915a1711f/ ); + is( $response->{owner_displayname}, '_acme_' ); + is( scalar @{ $response->{buckets} }, 9 ); +} + +for my $location ( undef, 'EU' ) { + + # create a bucket + # make sure it's a valid hostname for EU testing + # we use the same bucket name for both in order to force one or the other to + # have stale DNS + my $bucketname = 'net-amazon-s3-test-' . lc $aws_access_key_id; + + # for testing + # my $bucket = $s3->bucket($bucketname); $bucket->delete_bucket; exit; + + my $bucket_obj = $s3->add_bucket( + { bucket => $bucketname, + acl_short => 'public-read', + location_constraint => $location + } + ) or die $s3->err . ": " . $s3->errstr; + + is( ref $bucket_obj, "Net::Amazon::S3::Bucket" ); + is( $bucket_obj->get_location_constraint, $location ); + + like_acl_allusers_read($bucket_obj); + ok( $bucket_obj->set_acl( { acl_short => 'private' } ) ); + unlike_acl_allusers_read($bucket_obj); + + # another way to get a bucket object (does no network I/O, + # assumes it already exists). Read Net::Amazon::S3::Bucket. + $bucket_obj = $s3->bucket($bucketname); + is( ref $bucket_obj, "Net::Amazon::S3::Bucket" ); + + # fetch contents of the bucket + # note prefix, marker, max_keys options can be passed in + $response = $bucket_obj->list + or die $s3->err . ": " . $s3->errstr; + + is( $response->{bucket}, $bucketname ); + is( $response->{prefix}, '' ); + is( $response->{marker}, '' ); + is( $response->{max_keys}, 1_000 ); + is( $response->{is_truncated}, 0 ); + is_deeply( $response->{keys}, [] ); + + is( undef, $bucket_obj->get_key("non-existing-key") ); + + my $keyname = 'testing.txt'; + + { + + # Create a publicly readable key, then turn it private with a short acl. + # This key will persist past the end of the block. + my $value = 'T'; + $bucket_obj->add_key( + $keyname, $value, + { content_type => 'text/plain', + 'x-amz-meta-colour' => 'orange', + acl_short => 'public-read', + } + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname", + 200, "can access the publicly readable key" ); + + like_acl_allusers_read( $bucket_obj, $keyname ); + + ok( $bucket_obj->set_acl( + { key => $keyname, acl_short => 'private' } + ) + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname", + 403, "cannot access the private key" ); + + unlike_acl_allusers_read( $bucket_obj, $keyname ); + + ok( $bucket_obj->set_acl( + { key => $keyname, + acl_xml => acl_xml_from_acl_short('public-read') + } + ) + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname", + 200, "can access the publicly readable key after acl_xml set" ); + + like_acl_allusers_read( $bucket_obj, $keyname ); + + ok( $bucket_obj->set_acl( + { key => $keyname, + acl_xml => acl_xml_from_acl_short('private') + } + ) + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname", + 403, "cannot access the private key after acl_xml set" ); + + unlike_acl_allusers_read( $bucket_obj, $keyname ); + + } + + { + + # Create a private key, then make it publicly readable with a short + # acl. Delete it at the end so we're back to having a single key in + # the bucket. + + my $keyname2 = 'testing2.txt'; + my $value = 'T2'; + $bucket_obj->add_key( + $keyname2, + $value, + { content_type => 'text/plain', + 'x-amz-meta-colour' => 'blue', + acl_short => 'private', + } + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname2", + 403, "cannot access the private key" ); + + unlike_acl_allusers_read( $bucket_obj, $keyname2 ); + + ok( $bucket_obj->set_acl( + { key => $keyname2, acl_short => 'public-read' } + ) + ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname2", + 200, "can access the publicly readable key" ); + + like_acl_allusers_read( $bucket_obj, $keyname2 ); + + $bucket_obj->delete_key($keyname2); + + } + + { + + # Copy a key, keeping metadata + my $keyname2 = 'testing2.txt'; + + $bucket_obj->copy_key( $keyname2, "/$bucketname/$keyname" ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname2", + 403, "cannot access the private key" ); + + # Overwrite, making publically readable + $bucket_obj->copy_key( $keyname2, "/$bucketname/$keyname", + { acl_short => 'public-read' } ); + + sleep 1; + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname2", + 200, "can access the publicly readable key" ); + + # Now copy it over itself, making it private + $bucket_obj->edit_metadata( $keyname2, { short_acl => 'private' } ); + + is_request_response_code( + "http://$bucketname.s3.amazonaws.com/$keyname2", + 403, "cannot access the private key" ); + + # Get rid of it, bringing us back to only one key + $bucket_obj->delete_key($keyname2); + + # Expect a nonexistent key copy to fail + ok( !$bucket_obj->copy_key( "newkey", "/$bucketname/$keyname2" ), + "Copying a nonexistent key fails" ); + + } + + # list keys in the bucket + $response = $bucket_obj->list + or die $s3->err . ": " . $s3->errstr; + is( $response->{bucket}, $bucketname ); + is( $response->{prefix}, '' ); + is( $response->{marker}, '' ); + is( $response->{max_keys}, 1_000 ); + is( $response->{is_truncated}, 0 ); + my @keys = @{ $response->{keys} }; + is( @keys, 1 ); + my $key = $keys[0]; + is( $key->{key}, $keyname ); + + # the etag is the MD5 of the value + is( $key->{etag}, 'b9ece18c950afbfa6b0fdbfa4ff731d3' ); + is( $key->{size}, 1 ); + + is( $key->{owner_id}, $OWNER_ID ); + is( $key->{owner_displayname}, $OWNER_DISPLAYNAME ); + + # You can't delete a bucket with things in it + ok( !$bucket_obj->delete_bucket() ); + + $bucket_obj->delete_key($keyname); + + # now play with the file methods + my $readme_md5 = file_md5_hex('README'); + my $readme_size = -s 'README'; + $keyname .= "2"; + $bucket_obj->add_key_filename( + $keyname, 'README', + { content_type => 'text/plain', + 'x-amz-meta-colour' => 'orangy', + } + ); + + $response = $bucket_obj->get_key($keyname); + is( $response->{content_type}, 'text/plain' ); + like( $response->{value}, qr/and unknown Amazon/ ); + is( $response->{etag}, $readme_md5 ); + is( $response->{'x-amz-meta-colour'}, 'orangy' ); + is( $response->{content_length}, $readme_size ); + + unlink('t/README'); + $response = $bucket_obj->get_key_filename( $keyname, undef, 't/README' ); + + is( $response->{content_type}, 'text/plain' ); + is( $response->{value}, '' ); + is( $response->{etag}, $readme_md5 ); + is( file_md5_hex('t/README'), $readme_md5 ); + is( $response->{'x-amz-meta-colour'}, 'orangy' ); + is( $response->{content_length}, $readme_size ); + + $bucket_obj->delete_key($keyname); + + # try empty files + $keyname .= "3"; + $bucket_obj->add_key( $keyname, '' ); + $response = $bucket_obj->get_key($keyname); + is( $response->{value}, '' ); + is( $response->{etag}, 'd41d8cd98f00b204e9800998ecf8427e' ); + is( $response->{content_type}, 'binary/octet-stream' ); + is( $response->{content_length}, 0 ); + $bucket_obj->delete_key($keyname); + + # how about using add_key_filename? + $keyname .= '4'; + open FILE, ">", "t/empty" or die "Can't open t/empty for write: $!"; + close FILE; + $bucket_obj->add_key_filename( $keyname, 't/empty' ); + $response = $bucket_obj->get_key($keyname); + is( $response->{value}, '' ); + is( $response->{etag}, 'd41d8cd98f00b204e9800998ecf8427e' ); + is( $response->{content_type}, 'binary/octet-stream' ); + is( $response->{content_length}, 0 ); + $bucket_obj->delete_key($keyname); + unlink 't/empty'; + + # fetch contents of the bucket + # note prefix, marker, max_keys options can be passed in + $response = $bucket_obj->list + or die $s3->err . ": " . $s3->errstr; + is( $response->{bucket}, $bucketname ); + is( $response->{prefix}, '' ); + is( $response->{marker}, '' ); + is( $response->{max_keys}, 1_000 ); + is( $response->{is_truncated}, 0 ); + is_deeply( $response->{keys}, [] ); + + ok( $bucket_obj->delete_bucket() ); +} + +# see more docs in Net::Amazon::S3::Bucket + +# local test methods +sub is_request_response_code { + my ( $url, $code, $message ) = @_; + my $request = HTTP::Request->new( 'GET', $url ); + + #warn $request->as_string(); + my $response = $s3->ua->request($request); + is( $response->code, $code, $message ); +} + +sub like_acl_allusers_read { + my ( $bucketobj, $keyname ) = @_; + my $message = acl_allusers_read_message( 'like', @_ ); + like( $bucketobj->get_acl($keyname), qr(AllUsers.+READ), $message ); +} + +sub unlike_acl_allusers_read { + my ( $bucketobj, $keyname ) = @_; + my $message = acl_allusers_read_message( 'unlike', @_ ); + unlike( $bucketobj->get_acl($keyname), qr(AllUsers.+READ), $message ); +} + +sub acl_allusers_read_message { + my ( $like_or_unlike, $bucketobj, $keyname ) = @_; + my $message + = $like_or_unlike . "_acl_allusers_read: " . $bucketobj->bucket; + $message .= " - $keyname" if $keyname; + return $message; +} + +sub acl_xml_from_acl_short { + my $acl_short = shift || 'private'; + + my $public_read = ''; + if ( $acl_short eq 'public-read' ) { + $public_read = qq~ + + + http://acs.amazonaws.com/groups/global/AllUsers + + READ + + ~; + } + + return qq~ + + + $OWNER_ID + $OWNER_DISPLAYNAME + + + + + $OWNER_ID + $OWNER_DISPLAYNAME + + FULL_CONTROL + + $public_read + + ~; +} + diff --git a/t/02client.t b/t/02client.t new file mode 100644 index 00000000..f9f69a58 --- /dev/null +++ b/t/02client.t @@ -0,0 +1,225 @@ +#!perl +use warnings; +use strict; +use lib 'lib'; +use Digest::MD5::File qw(file_md5_hex); +use LWP::Simple; +use File::stat; +use Test::More; +use Test::Exception; + +unless ( $ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) { + plan skip_all => 'Testing this module for real costs money.'; +} else { + plan tests => 31; +} + +use_ok('Net::Amazon::S3'); + +my $aws_access_key_id = $ENV{'AWS_ACCESS_KEY_ID'}; +my $aws_secret_access_key = $ENV{'AWS_ACCESS_KEY_SECRET'}; + +my $s3 = Net::Amazon::S3->new( + aws_access_key_id => $aws_access_key_id, + aws_secret_access_key => $aws_secret_access_key, + retry => 1, + +); + +my $readme_size = stat('README')->size; +my $readme_md5hex = file_md5_hex('README'); + +my $client = Net::Amazon::S3::Client->new( s3 => $s3 ); + +my @buckets = $client->buckets; + +TODO: { + local $TODO = "These tests only work if you're leon"; + my $first_bucket = $buckets[0]; + like( $first_bucket->owner_id, qr/^46a801915a1711f/, 'have owner id' ); + is( $first_bucket->owner_display_name, '_acme_', 'have display name' ); + is( scalar @buckets, 10, 'have a bunch of buckets' ); +} + +my $bucket_name = 'net-amazon-s3-test-' . lc $aws_access_key_id; + +my $bucket = $client->create_bucket( + name => $bucket_name, + acl_short => 'public-read', + location_constraint => 'US', +); + +is( $bucket->name, $bucket_name, 'newly created bucket has correct name' ); + +like( + $bucket->acl, + qr{[a-z0-9]{64}.+?[a-z0-9]{64}.+?FULL_CONTROLhttp://acs.amazonaws.com/groups/global/AllUsersREAD}, + 'newly created bucket is public-readable' +); + +is( $bucket->location_constraint, 'US', 'newly created bucket is in the US' ); + +my $stream = $bucket->list; +until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + $object->delete; + } +} + +my $count = 0; +$stream = $bucket->list; +until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + $count++; + } +} + +is( $count, 0, 'newly created bucket has no objects' ); + +my $object = $bucket->object( key => 'this is the key' ); +$object->put('this is the value'); + +my @objects; +$stream = $bucket->list; +until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + push @objects, $object; + } +} + +is( @objects, 1, 'have newly created key' ); + +is( $objects[0]->key, + 'this is the key', + 'newly created object has the right key' +); +is( $objects[0]->etag, + '94325a12f8db22ffb6934cc5f22f6698', + 'newly created object has the right etag' +); +is( $objects[0]->size, '17', 'newly created object has the right size' ); + +is( $object->get, + 'this is the value', + 'newly created object has the right value' +); + +is( $bucket->object( key => 'this is the key' )->get, + 'this is the value', + 'newly created object fetched by name has the right value' +); + +$object->delete; + +# upload a public object + +$object = $bucket->object( + key => 'this is the public key', + acl_short => 'public-read', + content_type => 'text/plain', +); +$object->put('this is the public value'); +is( get( $object->uri ), + 'this is the public value', + 'newly created public object is publically accessible' +); +is( ( head( $object->uri ) )[0], + 'text/plain', 'newly created public object has the right content type' ); +$object->delete; + +# delete a non-existant object + +$object = $bucket->object( key => 'not here' ); +throws_ok { $object->get } qr/NoSuchKey/, + 'getting non-existant object throws exception'; + +# upload a file with put_filename + +$object = $bucket->object( key => 'the readme' ); +$object->put_filename('README'); + +@objects = (); +$stream = $bucket->list; +until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + push @objects, $object; + } +} + +is( @objects, 1, 'have newly uploaded object' ); +is( $objects[0]->key, 'the readme', + 'newly uploaded object has the right key' ); +is( $objects[0]->etag, $readme_md5hex, + 'newly uploaded object has the right etag' ); +is( $objects[0]->size, $readme_size, + 'newly created object has the right size' ); + +ok( $objects[0]->last_modified, 'newly created object has a last modified' ); + +$object->delete; + +# upload a public object with put_filename + +$object = $bucket->object( + key => 'the public readme', + acl_short => 'public-read' +); +$object->put_filename('README'); +is( length( get( $object->uri ) ), + $readme_size, 'newly uploaded public object has the right size' ); +$object->delete; + +# upload a file with put_filename with known md5hex and size + +$object = $bucket->object( + key => 'the new readme', + etag => $readme_md5hex, + size => $readme_size +); +$object->put_filename('README'); + +@objects = (); +$stream = $bucket->list; +until ( $stream->is_done ) { + foreach my $object ( $stream->items ) { + push @objects, $object; + } +} + +is( @objects, 1, 'have newly uploaded object' ); +is( $objects[0]->key, + 'the new readme', + 'newly uploaded object has the right key' +); +is( $objects[0]->etag, $readme_md5hex, + 'newly uploaded object has the right etag' ); +is( $objects[0]->size, $readme_size, + 'newly created object has the right size' ); +ok( $objects[0]->last_modified, 'newly created object has a last modified' ); + +# download an object with get_filename + +if ( -f 't/README' ) { + unlink('t/README') || die $!; +} + +$object->get_filename('t/README'); +is( stat('t/README')->size, $readme_size, 'download has right size' ); +is( file_md5_hex('t/README'), $readme_md5hex, 'download has right etag' ); + +$object->delete; + +# upload a public object with put_filename with known md5hex and size +$object = $bucket->object( + key => 'the new public readme', + etag => $readme_md5hex, + size => $readme_size, + acl_short => 'public-read' +); +$object->put_filename( 'README', $readme_md5hex, $readme_size ); +is( length( get( $object->uri ) ), + $readme_size, 'newly uploaded public object has the right size' ); +$object->delete; + +$bucket->delete; + diff --git a/t/99-pod-coverage.t b/t/99-pod-coverage.t new file mode 100644 index 00000000..99e049ed --- /dev/null +++ b/t/99-pod-coverage.t @@ -0,0 +1,13 @@ +use Test::More; +eval "use Test::Pod::Coverage 1.00"; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" + if $@; +all_pod_coverage_ok( { also_private => [qr/^[A-Z_]+$/] } ); + +# Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that +# certain "die"s that happen inside evals are not actually inside evals, +# because caller() is broken if you turn on $^P like Module::Refresh does +# +# (I mean, if we've gotten to this line, then clearly the test didn't die, no?) +Test::Builder->new->{Test_Died} = 0; + diff --git a/t/99-pod.t b/t/99-pod.t new file mode 100644 index 00000000..5c3c7917 --- /dev/null +++ b/t/99-pod.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD: $@" if $@; +all_pod_files_ok();