r6641 - in /branches/upstream/libnet-amazon-s3-perl/current: CHANGES META.yml Makefile lib/Net/Amazon/S3.pm lib/Net/Amazon/S3/Bucket.pm t/01api.t

dmn at users.alioth.debian.org dmn at users.alioth.debian.org
Wed Aug 15 05:10:50 UTC 2007


Author: dmn
Date: Wed Aug 15 05:10:50 2007
New Revision: 6641

URL: http://svn.debian.org/wsvn/?sc=1&rev=6641
Log:
[svn-upgrade] Integrating new upstream version, libnet-amazon-s3-perl (0.38)

Removed:
    branches/upstream/libnet-amazon-s3-perl/current/Makefile
Modified:
    branches/upstream/libnet-amazon-s3-perl/current/CHANGES
    branches/upstream/libnet-amazon-s3-perl/current/META.yml
    branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3.pm
    branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Bucket.pm
    branches/upstream/libnet-amazon-s3-perl/current/t/01api.t

Modified: branches/upstream/libnet-amazon-s3-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-amazon-s3-perl/current/CHANGES?rev=6641&op=diff
==============================================================================
--- branches/upstream/libnet-amazon-s3-perl/current/CHANGES (original)
+++ branches/upstream/libnet-amazon-s3-perl/current/CHANGES Wed Aug 15 05:10:50 2007
@@ -1,4 +1,14 @@
 Revision history for Perl module Net::Amazon::S3:
+
+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

Modified: branches/upstream/libnet-amazon-s3-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-amazon-s3-perl/current/META.yml?rev=6641&op=diff
==============================================================================
--- branches/upstream/libnet-amazon-s3-perl/current/META.yml (original)
+++ branches/upstream/libnet-amazon-s3-perl/current/META.yml Wed Aug 15 05:10:50 2007
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name: Net-Amazon-S3
-version: 0.36
+version: 0.38
 author:
   - Leon Brocard <acme at astray.com> and unknown Amazon Digital Services programmers.
   - Brad Fitzpatrick <brad at danga.com> - return values, Bucket object

Modified: branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3.pm?rev=6641&op=diff
==============================================================================
--- branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3.pm (original)
+++ branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3.pm Wed Aug 15 05:10:50 2007
@@ -158,7 +158,7 @@
 __PACKAGE__->mk_accessors(
     qw(libxml aws_access_key_id aws_secret_access_key secure ua err errstr timeout)
 );
-our $VERSION = '0.36';
+our $VERSION = '0.38';
 
 my $AMAZON_HEADER_PREFIX = 'x-amz-';
 my $METADATA_PREFIX      = 'x-amz-meta-';
@@ -215,6 +215,7 @@
 
     my $ua = LWP::UserAgent->new( keep_alive => $KEEP_ALIVE_CACHESIZE );
     $ua->timeout( $self->timeout );
+    $ua->env_proxy;
     $self->ua($ua);
     $self->libxml( XML::LibXML->new );
     return $self;
@@ -264,6 +265,10 @@
 
 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
+
 =back
 
 Returns 0 on failure, Net::Amazon::S3::Bucket object on success
@@ -274,7 +279,18 @@
     my ( $self, $conf ) = @_;
     my $bucket = $conf->{bucket};
     croak 'must specify bucket' unless $bucket;
-    return 0 unless $self->_send_request_expect_nothing( 'PUT', $bucket, {} );
+
+    if ($conf->{acl_short}){
+        $self->_validate_acl_short($conf->{acl_short});
+    }
+
+    my $header_ref = ($conf->{acl_short})
+        ? {'x-amz-acl' => $conf->{acl_short}}
+        : {};
+
+    return 0 unless $self->_send_request_expect_nothing( 'PUT', $bucket,
+        $header_ref );
+
     return $self->bucket($bucket);
 }
 
@@ -605,6 +621,15 @@
     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";
+    }
+}
+
 # make the HTTP::Request object
 sub _make_request {
     my ( $self, $method, $path, $headers, $data, $metadata ) = @_;
@@ -616,7 +641,8 @@
 
     my $http_headers = $self->_merge_meta( $headers, $metadata );
 
-    $self->_add_auth_header( $http_headers, $method, $path );
+    $self->_add_auth_header( $http_headers, $method, $path )
+        unless exists $headers->{Authorization};
     my $protocol = $self->secure ? 'https' : 'http';
     my $url      = "$protocol://s3.amazonaws.com/$path";
     my $request  = HTTP::Request->new( $method, $url, $http_headers );
@@ -671,6 +697,16 @@
     # 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 {

Modified: branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Bucket.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Bucket.pm?rev=6641&op=diff
==============================================================================
--- branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Bucket.pm (original)
+++ branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Bucket.pm Wed Aug 15 05:10:50 2007
@@ -31,7 +31,10 @@
 
 sub _uri {
     my ( $self, $key ) = @_;
-    return $self->bucket . "/" . $self->account->_urlencode($key);
+    return ($key)
+        ? $self->bucket . "/" . $self->account->_urlencode($key)
+        : $self->bucket
+    ;
 }
 
 =head2 add_key
@@ -59,6 +62,12 @@
     my ( $self, $key, $value, $conf ) = @_;
     croak 'must specify key' unless $key && length $key;
 
+    if ($conf->{acl_short}) {
+        $self->account->_validate_acl_short($conf->{acl_short});
+        $conf->{'x-amz-acl'} = $conf->{acl_short};
+        delete $conf->{acl_short};
+    }
+
     return $self->account->_send_request_expect_nothing( 'PUT',
         $self->_uri($key), $conf, $value );
 }
@@ -101,12 +110,7 @@
         return undef;
     }
 
-    unless ( $response->code =~ /^2\d\d$/ ) {
-        $acct->err("network_error");
-        $acct->errstr( $response->status_line );
-        croak "Net::Amazon::S3: Amazon responded with "
-            . $response->status_line . "\n";
-    }
+    $acct->_croak_if_response_error($response);
 
     my $etag = $response->header('ETag');
     if ($etag) {
@@ -192,6 +196,107 @@
     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 $acct = $self->account;
+
+    my $request  = $acct->_make_request( 'GET', $self->_uri($key) . '?acl', {} );
+    my $response = $acct->_do_http($request);
+
+    if ( $response->code == 404 ) {
+        return undef;
+    }
+
+    $acct->_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 ||= {};
+
+    unless ($conf->{acl_xml} || $conf->{acl_short}){
+        croak "need either acl_xml or acl_short";
+    }
+
+    if ($conf->{acl_xml} && $conf->{acl_short}){
+        croak "cannot provide both acl_xml and acl_short";
+    }
+
+    my $path = $self->_uri($conf->{key}) . '?acl';
+
+    my $hash_ref = ($conf->{acl_short})
+        ? { 'x-amz-acl' => $conf->{acl_short} }
+        : { }
+    ;
+
+    my $xml = $conf->{acl_xml} || '';
+
+    return $self->account->_send_request_expect_nothing( 'PUT',
+        $path, $hash_ref, $xml );
+
+}
+
 # proxy up the err requests
 
 =head2 err

Modified: branches/upstream/libnet-amazon-s3-perl/current/t/01api.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-amazon-s3-perl/current/t/01api.t?rev=6641&op=diff
==============================================================================
--- branches/upstream/libnet-amazon-s3-perl/current/t/01api.t (original)
+++ branches/upstream/libnet-amazon-s3-perl/current/t/01api.t Wed Aug 15 05:10:50 2007
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+
 use warnings;
 use strict;
 use Test::More;
@@ -7,7 +8,7 @@
              plan skip_all => 'Testing this module for real costs money.';
          }
          else {
-             plan tests => 31;
+             plan tests => 51;
          }
 
 
@@ -30,10 +31,11 @@
 # 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";
-    $OWNER_ID          = $response->{owner_id};
-    $OWNER_DISPLAYNAME = $response->{owner_displayname};
 
     like( $response->{owner_id},          qr/^46a801915a1711f/ );
     is( $response->{owner_displayname}, '_acme_' );
@@ -42,9 +44,14 @@
 
 # create a bucket
 my $bucketname = $aws_access_key_id . '-net-amazon-s3-test';
-my $bucket_obj = $s3->add_bucket( { bucket => $bucketname } )
+my $bucket_obj
+    = $s3->add_bucket( { bucket => $bucketname, acl_short => 'public-read' } )
     or die $s3->err . ": " . $s3->errstr;
 is( ref $bucket_obj, "Net::Amazon::S3::Bucket" );
+
+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.
@@ -62,15 +69,96 @@
 is( $response->{is_truncated}, 0 );
 is_deeply( $response->{keys}, [] );
 
-# store a key with a content-type and some optional metadata
+is(undef, $bucket_obj->get_key("non-existing-key"));
+
 my $keyname = 'testing.txt';
-my $value   = 'T';
-$bucket_obj->add_key(
-    $keyname, $value,
-    {   content_type        => 'text/plain',
-        'x-amz-meta-colour' => 'orange',
-    }
-);
+
+{
+    # 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://s3.amazonaws.com/$bucketname/$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://s3.amazonaws.com/$bucketname/$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://s3.amazonaws.com/$bucketname/$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://s3.amazonaws.com/$bucketname/$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://s3.amazonaws.com/$bucketname/$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://s3.amazonaws.com/$bucketname/$keyname2",
+        200, "can access the publicly readable key" );
+
+    like_acl_allusers_read($bucket_obj, $keyname2);
+
+    $bucket_obj->delete_key($keyname2);
+
+}
 
 # list keys in the bucket
 $response = $bucket_obj->list
@@ -111,3 +199,68 @@
 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 ($bucket_obj->get_acl($keyname) , qr(AllUsers.+READ), $message);
+}
+
+sub unlike_acl_allusers_read {
+    my ($bucketobj, $keyname) = @_;
+    my $message = acl_allusers_read_message('unlike', @_);
+    unlike ($bucket_obj->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~
+            <Grant>
+                <Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+                    xsi:type="Group">
+                    <URI>http://acs.amazonaws.com/groups/global/AllUsers</URI>
+                </Grantee>
+                <Permission>READ</Permission>
+            </Grant>
+        ~;
+    }
+
+    return qq~<?xml version="1.0" encoding="UTF-8"?>
+    <AccessControlPolicy xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
+        <Owner>
+            <ID>$OWNER_ID</ID>
+            <DisplayName>$OWNER_DISPLAYNAME</DisplayName>
+        </Owner>
+        <AccessControlList>
+            <Grant>
+                <Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+                    xsi:type="CanonicalUser">
+                    <ID>$OWNER_ID</ID>
+                    <DisplayName>$OWNER_DISPLAYNAME</DisplayName>
+                </Grantee>
+                <Permission>FULL_CONTROL</Permission>
+            </Grant>
+            $public_read
+        </AccessControlList>
+    </AccessControlPolicy>~;
+}




More information about the Pkg-perl-cvs-commits mailing list