File Coverage

blib/lib/Amazon/S3/Thin.pm

Criterion	Covered	Total	%
statement	157	186	84.4
branch	57	80	71.2
condition	14	29	48.2
subroutine	28	32	87.5
pod	15	15	100.0
total	271	342	79.2

package Amazon::S3::Thin;
use 5.008001;
use strict;
use warnings;
use Carp;
use LWP::UserAgent;
use Digest::MD5;
use Encode;
use Amazon::S3::Thin::Resource;
use Amazon::S3::Thin::Credentials;

our $VERSION = '0.30';

my $METADATA_PREFIX      = 'x-amz-meta-';
my $MAIN_HOST = 's3.amazonaws.com';

sub new {
    my $class = shift;
    my $self  = shift;

    # If we have an explicitly-configured credential provider then use that here, otherwise
    # existing behaviour will be followed
    if ($self->{credential_provider} and $self->{credential_provider} eq 'env') {
        $self->{credentials} = Amazon::S3::Thin::Credentials->from_env;
    }
    elsif ($self->{credential_provider} and $self->{credential_provider} eq 'metadata') {
        $self->{credentials} = Amazon::S3::Thin::Credentials->from_metadata($self);
    }
    else {
        # check existence of credentials
        croak "No aws_access_key_id"     unless $self->{aws_access_key_id};
        croak "No aws_secret_access_key" unless $self->{aws_secret_access_key};

        # wrap credentials
        $self->{credentials} = Amazon::S3::Thin::Credentials->new(
            $self->{aws_access_key_id},
            $self->{aws_secret_access_key},
            $self->{aws_session_token},
        );
        delete $self->{aws_access_key_id};
        delete $self->{aws_secret_access_key};
        delete $self->{aws_session_token};
    }
    delete $self->{credential_provider};

    bless $self, $class;

    $self->secure(0)                unless defined $self->secure;
    $self->ua($self->_default_ua)   unless defined $self->ua;
    $self->debug(0)                 unless defined $self->debug;
    $self->virtual_host(0)          unless defined $self->virtual_host;

    $self->{signature_version} = 4  unless defined $self->{signature_version};
    if ($self->{signature_version} == 4 && ! $self->{region}) {
        croak "Please set region when you use signature v4";
    }

    $self->{signer} = $self->_load_signer($self->{signature_version});
    return $self;
}

sub _load_signer {
  my $self = shift;
  my $version = shift;
  my $signer_class = "Amazon::S3::Thin::Signer::V$version";
  eval "require $signer_class" or die $@;

  if ($version == 2) {
      return $signer_class->new($self->{credentials}, $MAIN_HOST);
  } elsif ($version == 4) {
      return $signer_class->new($self->{credentials}, $self->{region});
  }
}


sub _default_ua {
    my $self = shift;

    my $ua = LWP::UserAgent->new(
        keep_alive            => 10,
        requests_redirectable => [qw(GET HEAD DELETE PUT)],
        );
    $ua->timeout(30);
    $ua->env_proxy;
    return $ua;
}

# Accessors

sub secure {
    my $self = shift;
    if (@_) {
        $self->{secure} = shift;
    } else {
        return $self->{secure};
    }
}

sub debug {
    my $self = shift;
    if (@_) {
        $self->{debug} = shift;
    } else {
        return $self->{debug};
    }
}

sub ua {
    my $self = shift;
    if (@_) {
        $self->{ua} = shift;
    } else {
        return $self->{ua};
    }
}

sub virtual_host {
    my $self = shift;
    if (@_) {
        $self->{virtual_host} = shift;
    } else {
        return $self->{virtual_host};
    }
}

sub _send {
    my ($self, $request) = @_;
    warn "[Request]\n" , $request->as_string if $self->{debug};
    my $response = $self->ua->request($request);
    warn "[Response]\n" , $response->as_string if $self->{debug};
    return $response;
}

# API calls

sub get_object {
    my ($self, $bucket, $key, $headers) = @_;
    my $request = $self->_compose_request('GET', $self->_resource($bucket, $key), $headers);
    return $self->_send($request);
}

sub head_object {
    my ($self, $bucket, $key) = @_;
    my $request = $self->_compose_request('HEAD', $self->_resource($bucket, $key));
    return $self->_send($request);
}

sub delete_object {
    my ($self, $bucket, $key) = @_;
    my $request = $self->_compose_request('DELETE', $self->_resource($bucket, $key));
    return $self->_send($request);
}

sub copy_object {
    my ($self, $src_bucket, $src_key, $dst_bucket, $dst_key, $headers) = @_;
    $headers ||= {};
    $headers->{'x-amz-copy-source'} = $src_bucket . "/" . $src_key;
    my $request = $self->_compose_request('PUT', $self->_resource($dst_bucket, $dst_key), $headers);
    my $res = $self->_send($request);

    # XXX: Since the COPY request might return error response in 200 OK, we'll rewrite the status code to 500 for convenience
    # ref http://docs.aws.amazon.com/AmazonS3/latest/API/RESTObjectCOPY.html
    # ref https://github.com/boto/botocore/blob/4e9b4419ec018716ab1a3fe1587fbdc3cfef200e/botocore/handlers.py#L77-L120
    if ($self->_looks_like_special_case_error($res)) {
        $res->code(500);
    }
    return $res;
}

sub _looks_like_special_case_error {
    my ($self, $res) = @_;
    return $res->code == 200 && (length $res->content == 0 || $res->content =~ //);
}

sub put_object {
    my ($self, $bucket, $key, $content, $headers) = @_;
    croak 'must specify key' unless $key && length $key;

    if ($headers->{acl_short}) {
        $self->_validate_acl_short($headers->{acl_short});
        $headers->{'x-amz-acl'} = $headers->{acl_short};
        delete $headers->{acl_short};
    }

    if (ref($content) eq 'SCALAR') {
        $headers->{'Content-Length'} ||= -s $$content;
        $content = _content_sub($$content);
    }
    else {
        $headers->{'Content-Length'} ||= length $content;
    }

    if (ref($content)) {
        # TODO
        # I do not understand what it is :(
        #
        # return $self->_send_request_expect_nothing_probed('PUT',
        #    $self->_resource($bucket, $key), $headers, $content);
        #
        die "unable to handle reference";
    }
    else {
        my $request = $self->_compose_request('PUT', $self->_resource($bucket, $key), $headers, $content);
        return $self->_send($request);
    }
}

sub list_objects {
    my ($self, $bucket, $opt) = @_;
    croak 'must specify bucket' unless $bucket;
    $opt ||= {};

    my $query_string;
    if (%$opt) {
        $query_string = join('&',
                 map { $_ . "=" . Amazon::S3::Thin::Resource->urlencode($opt->{$_}) } sort keys %$opt);
    }

    my $resource = $self->_resource($bucket, undef, $query_string);
    my $request = $self->_compose_request('GET', $resource);
    my $response = $self->_send($request);
    return $response;
}

sub delete_multiple_objects {
    my ($self, $bucket, @keys) = @_;

    my $content = _build_xml_for_delete(@keys);
    # XXX: specify an empty string with `delete` query for calculating signature correctly in AWS::Signature4
    my $resource = $self->_resource($bucket, undef, 'delete=');
    my $request = $self->_compose_request(
        'POST',
        $resource,
        {
            'Content-MD5'    => Digest::MD5::md5_base64($content) . '==',
            'Content-Length' => length $content,
        },
        $content
    );
    my $response = $self->_send($request);
    return $response;
}

sub _build_xml_for_delete {
    my (@keys) = @_;

    my $content = 'true';

    foreach my $k (@keys) {
        $content .= ''
                  . Encode::encode('UTF-8', $k)
                  . '';
    }
    $content .= '';

    return $content;
}

# Operations on Buckets

sub put_bucket {
    my ($self, $bucket, $headers) = @_;
    #
    # https://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region
    my $region = $self->{region};
    my $content ;
    if ($region eq "us-east-1") {
        $content = "";
    } else {
        my $location_constraint = "$region";
        $content = <<"EOT";
$location_constraint
EOT
    }

    my $request = $self->_compose_request('PUT', $self->_resource($bucket), $headers, $content);
    return $self->_send($request);
}

sub delete_bucket {
    my ($self, $bucket) = @_;
    my $request = $self->_compose_request('DELETE', $self->_resource($bucket));
    return $self->_send($request);
}

sub generate_presigned_post {
    my ($self, $bucket, $key, $fields, $conditions, $expires_in) = @_;

    croak 'must specify bucket' unless defined $bucket;
    croak 'must specify key' unless defined $key;

    if ($self->{signature_version} == 4) {
        my $resource = $self->_resource($bucket);
        my $protocol = $self->secure ? 'https' : 'http';

        return {
            ($self->virtual_host
                ? (url => $resource->to_virtual_hosted_style_url($protocol))
                : (url => $resource->to_path_style_url($protocol, $self->{region}))),
            fields => $self->{signer}->_generate_presigned_post(
                $bucket, $key, $fields, $conditions, $expires_in
            ),
        };
    } else {
        croak 'generate_presigned_post is only supported on signature v4';
    }
}

sub _resource {
    my ($self, $bucket, $key, $query_string) = @_;
    return Amazon::S3::Thin::Resource->new($bucket, $key, $query_string);
}

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 _compose_request {
    my ($self, $method, $resource, $headers, $content, $metadata) = @_;
    croak 'must specify method' unless $method;
    croak 'must specify resource'   unless defined $resource;
    if (ref $resource ne 'Amazon::S3::Thin::Resource') {
        croak 'resource must be an instance of Amazon::S3::Thin::Resource';
    }
    $headers ||= {};
    $metadata ||= {};

    # generates an HTTP::Headers objects given one hash that represents http
    # headers to set and another hash that represents an object's metadata.
    my $http_headers = HTTP::Headers->new;
    while (my ($k, $v) = each %$headers) {
        $http_headers->header($k => $v);
    }
    while (my ($k, $v) = each %$metadata) {
        $http_headers->header("$METADATA_PREFIX$k" => $v);
    }

    my $protocol = $self->secure ? 'https' : 'http';

    my $url;

    if ($self->{signature_version} == 4) {
        if ($self->virtual_host) {
            $url = $resource->to_virtual_hosted_style_url($protocol);
        } else {
            $url = $resource->to_path_style_url($protocol, $self->{region});
        }
    } else {
        $url = $resource->to_url_without_region($protocol, $MAIN_HOST);
    }

    my $request = HTTP::Request->new($method, $url, $http_headers, $content);
    # sign the request using the signer, unless already signed
    if (!$request->header('Authorization')) {
        $self->{signer}->sign($request);
    }
    return $request;
}

1;

__END__