view release on metacpan or  search on metacpan

lib/Furl/S3.pm  view on Meta::CPAN

package Furl::S3;

use strict;
use warnings;
use Class::Accessor::Lite;
use Furl::HTTP qw(HEADERS_AS_HASHREF);
use Digest::HMAC_SHA1;
use MIME::Base64 qw(encode_base64);
use HTTP::Date;
use Data::Dumper;
use XML::LibXML;
use XML::LibXML::XPathContext;
use Furl::S3::Error;
use Params::Validate qw(:types validate_with validate_pos);
use URI::Escape qw(uri_escape_utf8);
use Carp ();

Class::Accessor::Lite->mk_accessors(qw(aws_access_key_id aws_secret_access_key secure furl endpoint));

our $VERSION = '0.02';
our $DEFAULT_ENDPOINT = 's3.amazonaws.com';
our $XMLNS = 'http://s3.amazonaws.com/doc/2006-03-01/';

sub new {
    my $class = shift;
    validate_with( 
        params => \@_, 
        spec => {
            aws_access_key_id => 1,
            aws_secret_access_key => 1,
        },
        allow_extra => 1,
    );
    my %args = @_;
    my $aws_access_key_id = delete $args{aws_access_key_id};
    my $aws_secret_access_key = delete $args{aws_secret_access_key};
    Carp::croak("aws_access_key_id and aws_secret_access_key are mandatory") unless $aws_access_key_id && $aws_secret_access_key;
    my $secure = delete $args{secure} || '0';
    my $endpoint = delete $args{endpoint} || $DEFAULT_ENDPOINT;
    my $furl = Furl::HTTP->new( 
        agent => '$class/'. $VERSION,
        %args,
        header_format => HEADERS_AS_HASHREF,
    );
    my $self = bless {
        endpoint => $endpoint,
        secure => $secure,
        aws_access_key_id => $aws_access_key_id,
        aws_secret_access_key => $aws_secret_access_key,
        furl => $furl,
    }, $class;
    $self;
}

sub _trim {
    my $str = shift;
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    $str;
}

sub _remove_quote {
    my $str = shift;
    $str =~ s/^"//;
    $str =~ s/"$//;
    $str;
}

sub _boolean {
    my $str = shift;
    if ( $str eq 'false' ) {
        return 0;
    }
    return 1;
}

# http://docs.amazonwebservices.com/AmazonS3/2006-03-01/dev/index.html?BucketRestrictions.html
sub validate_bucket {
    my $bucket = shift;
    return 
        ($bucket =~ qr/^[a-z0-9][a-z0-9\._-]{2,254}$/) && 
            ($bucket !~ /^\d+\.\d+\.\d+\.\d+$/); # IP Address
}

sub is_dns_style {
    my $bucket = shift;
    return unless validate_bucket( $bucket );
    return if $bucket =~ /_/;
    return if length($bucket) < 3 || length($bucket) > 63;
    return if $bucket =~ /\.\./;
    my @parts = split /\./, $bucket;
    for my $p(@parts) {
        return if $p =~ /-$/
    }
    return 1;
}

sub string_to_sign {
    my( $self, $method, $resource, $headers ) = @_;
    $headers ||= {};
    my %headers_to_sign;
    while (my($k, $v) = each %{$headers}) {
        my $key = lc $k;
        if ( $key =~ /^(content-md5|content-type|date|expires)$/ or 
                 $key =~ /^x-amz-/ ) {
            $headers_to_sign{$key} = _trim($v);
        }
    }
    my $str = "$method\n";
    $str .= $headers_to_sign{'content-md5'} || '';
    $str .= "\n";
    $str .= $headers_to_sign{'content-type'} || '';
    $str .= "\n";
    $str .= $headers_to_sign{'expires'} || $headers_to_sign{'date'} || '';
    $str .= "\n";
    for my $key( sort grep { /^x-amz-/ } keys %headers_to_sign ) {
        $str .= "$key:$headers_to_sign{$key}\n";
    }
    my( $path, $query ) = split /\?/, $resource;
    # sub-resource.
    if ( $query && $query =~ m{^(acl|policy|location|versions)$} ) {
        $str .= $resource;
    }
    else {
        $str .= $path;
    }

    $str;
}

sub sign {
    my( $self, $str ) = @_;
    my $hmac = Digest::HMAC_SHA1->new( $self->aws_secret_access_key );
    $hmac->add( $str );
    encode_base64( $hmac->digest, '' );
}

sub resource {
    my( $self, $bucket, $key, $subresource ) = @_;
    my $resource = $bucket;
    $resource = '/'. $resource unless $resource =~ m{^/};
    if ( defined $key ) {
        $key = _normalize_key($key);
        $resource = join '/', $resource, $key;
    }
    if ( $subresource ) {
        $resource .= '?'. $subresource;
    }
    $resource =~ s{//}{/}g;
    $resource;
}

sub _path_query {
    my( $self, $path, $q ) = @_;
    $path = '/'. $path unless $path =~ m{^/};
    my $qs = ref($q) eq 'HASH' ? 
        join('&', map { $_. '='. uri_escape_utf8( $q->{$_} ) } keys %{$q}) : $q;
    $path .= '?'. $qs if $qs;
    $path;
}

sub host_and_path_query {
    my( $self, $bucket, $key, $params ) = @_;
    my($host, $path_query);
    $key = _normalize_key($key);
    if ( is_dns_style($bucket) ) {
        $host = join '.', $bucket, $self->endpoint;
        $path_query = $self->_path_query( $key, $params );
    }
    else {
        $host = $self->endpoint;
        $path_query = $self->_path_query( join('/', $bucket, $key), $params );
    }
    $path_query =~ s{//}{/}g;
    return ($host, $path_query);
}

sub request {
    my $self = shift;
    my( $method, $bucket, $key, $params, $headers, $furl_options ) = @_;
    validate_pos( @_, 1, 1, 
                  { type => SCALAR | UNDEF, optional => 1 },
                  { type => HASHREF | UNDEF | SCALAR , optional => 1, }, 
                  { type => HASHREF | UNDEF , optional => 1, },
                  { type => HASHREF | UNDEF , optional => 1, }, );
    $self->clear_error;
    $key ||= '';
    $params ||= +{};
    $headers ||= +{};
    $furl_options ||= +{};

    my %h;
    while (my($key, $val) = each %{$headers}) {
        $key =~ s/_/-/g; # content_type => content-type
        $h{lc($key)} = $val
    }
    if ( !$h{'expires'} && !$h{'date'} ) {
        $h{'date'} = time2str(time);
    }
    my $resource = $self->resource( $bucket, $key );
    my $string_to_sign = 
        $self->string_to_sign( $method, $resource, \%h );
    my $signed_string = $self->sign( $string_to_sign );
    my $auth_header = 'AWS '. $self->aws_access_key_id. ':'. $signed_string;
    $h{'authorization'} = $auth_header;

    my( $host, $path_query ) = 
        $self->host_and_path_query( $bucket, $key, $params );
    my %res;
    my @h = %h;
    @res{qw(ver code msg headers body)} = $self->furl->request(
        method => $method,
        scheme => ($self->secure ? 'https' : 'http'),
        host => $host,
        path_query => $path_query,
        headers => \@h,
        %{$furl_options},
    );
    return \%res;
}

sub signed_url {
    my $self = shift;
    validate_pos(@_, 1, 1, +{ regexp => qr/^\d+$/, });
    my( $bucket, $key, $expires ) = @_;
    my $resource = $self->resource( $bucket, $key );
    my $string_to_sign = $self->string_to_sign('GET', $resource, +{
        expires => $expires,
    });
    my $sig = $self->sign( $string_to_sign );
    my($host, $path_query) = $self->host_and_path_query( $bucket, $key, +{

lib/Furl/S3.pm  view on Meta::CPAN

sub _uri_escape {
    uri_escape_utf8($_[0], '^A-Za-z0-9\._-');
}
1;


__END__

=head1 NAME

Furl::S3 - Furl based S3 client library.

=head1 SYNOPSIS

  use Furl::S3;

  my $s3 = Furl::S3->new( 
      aws_access_key_id => '...', 
      aws_secret_access_key => '...',
  );
  $s3->create_bucket($bucket) or die $s3->error;

  my $res = $s3->list_objects($bucket) or die $s3->error;
  for my $obj(@{$res->{contents}}) {
      printf "%s\n", $obj->{key};
  }

=head1 DESCRIPTION

This module uses L<Furl> lightweight HTTP client library and provides very simple interfaces to Amazon Simple Storage Service (Amazon S3)

for more details. see Amazon S3's developer guide and API References.

http://docs.amazonwebservices.com/AmazonS3/2006-03-01/dev/

http://docs.amazonwebservices.com/AmazonS3/2006-03-01/API/

=head1 METHODS

=head2 Furl::S3->new( %args )

returns a new Furl::S3 object.

I<%args> are below.

=over

=item aws_access_key_id 

AWS Access Key ID

=item aws_secret_access_key

AWS Secret Access Key.

=item secure

boolean flag. uses SSL connection or not.

=item endpoint

S3 endpoint hostname. the default value is I<s3.amazonaws.com>

other parmeters are passed to Furl->new. see L<Furl> documents.

=back

=head2 request($method, $bucket, [ $key ], [ \%params ], [ \%headers ], [ \%furl_options ]);

sends signed request. returns a Furl::Response object.

=over

=item $method

HTTP Request Method.

=item $bucket

bucket name.

=item $key

key of object.

=item \%params

request parameters.

=item \%headers

HTTP headers.

=item \%furl_options

arguments of $furl->request.

=back

=head2 list_buckets

list all buckets.
returns a HASH-REF

  {
      'owner' => {
        'id' => '...',
        'display_name' => '..'
      },
      'buckets' => [
          {
              'creation_date' => '2010-11-30T00:00:00.000Z',
              'name' => 'Your bucket name'
          },
          #...
      ]
  }

=head2 create_bucket($bucket, [ \%headers ])

create new bucket.
returns a boolean value.