Amazon-S3-Lite
view release on metacpan or search on metacpan
lib/Amazon/S3/Lite.pm view on Meta::CPAN
########################################################################
# HTTP::Tiny instance - one per object, keep-alive enabled
########################################################################
sub _init_ua {
########################################################################
my ($self) = @_;
$self->{ua} = HTTP::Tiny->new(
timeout => $self->{timeout},
verify_SSL => $self->{secure},
);
return;
}
########################################################################
# Accessors
########################################################################
sub logger { return $_[0]->{logger} }
sub log_level { return $_[0]->{log_level}; }
sub ua { return $_[0]->{ua} }
sub region { return $_[0]->{region} }
sub host { return $_[0]->{host} }
sub credentials { return $_[0]->{credentials} }
########################################################################
# Build a fresh signer from current credentials.
# Called per-request so that rotating credentials (Lambda IAM roles)
# are always current.
########################################################################
sub _signer {
########################################################################
my ( $self, $region ) = @_;
my $creds = $self->credentials;
my $access_key
= $creds->can('get_aws_access_key_id')
? $creds->get_aws_access_key_id
: $creds->aws_access_key_id;
my $secret_key
= $creds->can('get_aws_secret_access_key')
? $creds->get_aws_secret_access_key
: $creds->aws_secret_access_key;
my $token_sub = $creds->can('get_token') // $creds->can('token');
my $token = $token_sub ? $token_sub->($creds) : undef;
return Amazon::Signature4::Lite->new(
access_key => $access_key,
secret_key => $secret_key,
session_token => $token,
region => $region // $self->region,
service => 's3',
);
}
########################################################################
# Build the endpoint URL for a bucket/key
########################################################################
sub _endpoint {
########################################################################
my ( $self, $bucket, $key ) = @_;
my $scheme = $self->{secure} ? 'https' : 'http';
my $host = $self->host;
# Path-style URL: https://s3.amazonaws.com/bucket/key
# (virtual-hosted style omitted for simplicity; path-style works
# everywhere and avoids SSL cert issues with dotted bucket names)
my $url = "$scheme://$host";
$url .= "/$bucket" if defined $bucket && length $bucket;
$url .= '/' . _encode_key($key) if defined $key && length $key;
return $url;
}
########################################################################
# URI-encode an S3 key, preserving '/' separators
########################################################################
sub _encode_key {
########################################################################
my ($key) = @_;
return join '/', map { uri_escape_utf8( $_, '^A-Za-z0-9\-._~' ) }
split m{/}, $key, -1;
}
########################################################################
sub _request {
########################################################################
my ( $self, $method, $url, $headers, $content, $extra, $region ) = @_;
$region //= $self->region;
$headers //= {};
$content //= q{};
$extra //= {};
my $content_is_coderef = ref $content eq 'CODE';
# sign — returns merged headers ready for HTTP::Tiny
my $signed = $self->_signer($region)->sign(
method => $method,
url => $url,
headers => $headers,
payload => $content_is_coderef ? q{} : $content,
);
# HTTP::Tiny sets Host itself — remove to avoid duplicate header error
delete $signed->{host};
$self->logger->debug("$method $url");
my $options = { headers => $signed };
if ( length $content || $content_is_coderef ) {
$options->{content} = $content;
}
if ( $extra->{data_callback} ) {
$options->{data_callback} = $extra->{data_callback};
}
my $response = $self->ua->request( $method, $url, $options );
$self->logger->debug( sprintf 'Response: %s %s', $response->{status}, $response->{reason} );
return $response;
}
########################################################################
# head_object( $bucket, $key )
#
# Fetches metadata for an object without retrieving the body.
# Returns undef if the key does not exist (404).
# Returns a hashref with content_type, content_length, etag,
# last_modified, and metadata (x-amz-meta-* headers).
########################################################################
sub head_object {
########################################################################
my ( $self, $bucket, $key ) = @_;
croak 'bucket is required' if !defined $bucket || !length $bucket;
croak 'key is required' if !defined $key || !length $key;
my $url = $self->_endpoint( $bucket, $key );
my $response = $self->_request( 'HEAD', $url );
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'head_object' );
return $self->_extract_object_metadata( $response->{headers} );
}
########################################################################
# Extract the standard object metadata hashref from a response headers
# hash. Used by both head_object and get_object.
########################################################################
sub _extract_object_metadata {
########################################################################
my ( $self, $headers ) = @_;
my $etag = $headers->{etag};
$etag =~ s/\A"|"\z//gxsm if defined $etag;
# Collect x-amz-meta-* headers, stripping the prefix from the key
my %metadata;
for my $name ( keys %{$headers} ) {
if ( $name =~ /^x-amz-meta-(.+)$/xsm ) {
$metadata{$1} = $headers->{$name};
}
}
return {
content_type => $headers->{'content-type'},
content_length => $headers->{'content-length'} + 0,
etag => $etag,
last_modified => $headers->{'last-modified'},
metadata => \%metadata,
};
}
########################################################################
# get_object( $bucket, $key, %options )
#
# Fetches an object from S3. Options:
# range => 'bytes=0-1023' partial fetch
# filename => '/tmp/foo' stream body to disk; omits content key
#
# Returns undef on 404.
# Returns a hashref with content_type, content_length, etag,
# last_modified, metadata, and content (unless filename is used).
########################################################################
sub get_object {
########################################################################
my ( $self, $bucket, $key, %options ) = @_;
croak 'bucket is required' if !defined $bucket || !length $bucket;
croak 'key is required' if !defined $key || !length $key;
my $url = $self->_endpoint( $bucket, $key );
my %headers;
$headers{Range} = $options{range} if defined $options{range};
my $filename = $options{filename};
my $extra = {};
if ( defined $filename ) {
# Open the destination file before making the request so we catch
# permission errors early, before network round-trip
open my $fh, '>', $filename
or croak "cannot open '$filename' for writing: $!";
$extra->{data_callback} = sub {
my ($data) = @_;
print {$fh} $data
or croak "write to '$filename' failed: $!";
};
my $response = $self->_request( 'GET', $url, \%headers, q{}, $extra );
close $fh
or croak "close of '$filename' failed: $!";
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'get_object' );
# Return metadata only — content is on disk
return $self->_extract_object_metadata( $response->{headers} );
}
# In-memory path
my $response = $self->_request( 'GET', $url, \%headers );
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'get_object' );
my $result = $self->_extract_object_metadata( $response->{headers} );
$result->{content} = $response->{content};
return $result;
}
########################################################################
# delete_object( $bucket, $key, %options )
#
# Deletes an object from S3. Options:
# version_id => $vid delete a specific version
#
# Returns true on success. Note S3 returns 204 for both successful
# deletes and deletes of non-existent keys — no distinction is made.
# Croaks on network or server errors.
########################################################################
sub delete_object {
########################################################################
my ( $self, $bucket, $key, %options ) = @_;
croak 'bucket is required' if !defined $bucket || !length $bucket;
croak 'key is required' if !defined $key || !length $key;
my $url = $self->_endpoint( $bucket, $key );
if ( defined $options{version_id} ) {
$url .= '?versionId=' . uri_escape_utf8( $options{version_id} );
}
my $response = $self->_request( 'DELETE', $url );
$self->_croak_on_error( $response, 'delete_object' );
return 1;
}
########################################################################
# create_bucket( $bucket, %options )
#
# Creates a new S3 bucket.
#
# us-east-1 is the S3 default region — the CreateBucketConfiguration
# body must NOT be sent for us-east-1 (S3 will error). All other regions
# require it with LocationConstraint set to the target region.
#
# Options: acl, region
#
# Returns true on success. Croaks on failure.
########################################################################
sub create_bucket {
########################################################################
my ( $self, $bucket, %options ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $region = $options{region} // $self->region;
my $url = $self->_endpoint($bucket);
my %headers;
$headers{'x-amz-acl'} = $options{acl} if $options{acl};
my $content = q{};
# us-east-1 is the implicit default — sending LocationConstraint for it
# causes an error. All other regions require it.
if ( $region ne 'us-east-1' ) {
$content
= sprintf '<CreateBucketConfiguration '
. 'xmlns="http://s3.amazonaws.com/doc/2006-03-01/">'
. '<LocationConstraint>%s</LocationConstraint>'
. '</CreateBucketConfiguration>',
$region;
$headers{'Content-Type'} = 'application/xml';
$headers{'Content-Length'} = length $content;
}
my $response = $self->_request( 'PUT', $url, \%headers, $content, {}, $region );
$self->_croak_on_error( $response, 'create_bucket' );
return 1;
}
########################################################################
sub delete_bucket {
########################################################################
my ( $self, $bucket, %options ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $region = $options{region} // $self->region;
my $url = $self->_endpoint($bucket);
my $response = $self->_request( 'DELETE', $url, {}, q{}, {}, $region );
$self->_croak_on_error( $response, 'delete_bucket' );
return $TRUE;
}
########################################################################
# list_buckets()
#
# Lists all buckets owned by the authenticated user.
#
# Note: ListBuckets is a global S3 operation and must always be signed
# against us-east-1 regardless of the region the object was constructed
# with. We pass the region override directly to the signer.
#
# Returns a hashref:
# {
# owner_id => '...',
# owner_name => '...',
# buckets => [
# { name => '...', creation_date => '...' },
# ...
# ],
# }
########################################################################
sub list_buckets {
########################################################################
my ($self) = @_;
my $url = $self->_endpoint . q{/}; # ensure canonical URI is / not empty
my $response = $self->_request( 'GET', $url, {}, q{}, {}, 'us-east-1' );
$self->_croak_on_error( $response, 'list_buckets' );
return $self->_parse_list_buckets( $response->{content} );
}
########################################################################
# Parse ListAllMyBucketsResult XML
########################################################################
########################################################################
sub _parse_list_buckets {
########################################################################
my ( $self, $xml ) = @_;
my ( @buckets, $owner_id, $owner_name );
XML::Twig->new(
twig_handlers => {
'Bucket' => sub {
my ( $t, $node ) = @_;
push @buckets,
{
name => $node->first_child_text('Name'),
creation_date => $node->first_child_text('CreationDate'),
};
},
'Owner' => sub {
my ( $t, $node ) = @_;
$owner_id = $node->first_child_text('ID');
$owner_name = $node->first_child_text('DisplayName');
},
}
)->parse($xml);
return {
owner_id => $owner_id,
owner_name => $owner_name,
buckets => \@buckets,
};
}
########################################################################
# copy_object( %args )
#
# Copies an object within or between buckets, entirely server-side.
# Required: src_bucket, src_key, dst_bucket, dst_key
#
# Note: S3 can return HTTP 200 with an XML error body for copy operations
# that fail mid-transfer. This method detects and croaks on that case.
#
# Returns a hashref: { etag => '...', last_modified => '...' }
########################################################################
sub copy_object {
########################################################################
my ( $self, %args ) = @_;
for my $required (qw( src_bucket src_key dst_bucket dst_key )) {
croak "$required is required"
if !defined $args{$required} || !length $args{$required};
}
my $url = $self->_endpoint( $args{dst_bucket}, $args{dst_key} );
# x-amz-copy-source: /src-bucket/encoded-key
my $copy_source = '/' . $args{src_bucket} . '/' . _encode_key( $args{src_key} );
my %headers = (
'x-amz-copy-source' => $copy_source,
'x-amz-tagging-directive' => 'COPY',
'Content-Length' => 0,
);
my $response = $self->_request( 'PUT', $url, \%headers );
$self->_croak_on_error( $response, 'copy_object' );
# S3 can return HTTP 200 with an XML error body for copies that fail
# after the headers have been sent. Detect this by checking the root
# element — a success response has <CopyObjectResult>, an error has <Error>.
return $self->_parse_copy_response( $response->{content}, 'copy_object' );
}
########################################################################
# Parse CopyObjectResult XML, detecting the 200-with-error edge case
########################################################################
########################################################################
sub _parse_copy_response {
########################################################################
my ( $self, $xml, $context ) = @_;
my $twig = XML::Twig->new->parse($xml);
my $root = $twig->root->tag;
if ( $root eq 'Error' ) {
my $code = $twig->root->first_child_text('Code');
my $msg = $twig->root->first_child_text('Message');
croak sprintf '%s failed: %s - %s', $context, $code, $msg;
}
my $etag = $twig->root->first_child_text('ETag') // q{};
$etag =~ s/\A"|"\z//gxsm;
return {
etag => $etag,
last_modified => $twig->root->first_child_text('LastModified'),
};
}
########################################################################
# put_object( $bucket, $key, $data, %options )
#
# Stores an object in S3. $data may be a scalar string, a reference to
# a scalar, or an open filehandle / IO::File object.
#
# Options: content_type, content_length, metadata (hashref), acl
#
# Returns the ETag of the stored object. Croaks on failure.
########################################################################
sub put_object {
########################################################################
my ( $self, $bucket, $key, $data, %options ) = @_;
croak 'bucket is required' if !defined $bucket || !length $bucket;
croak 'key is required' if !defined $key || !length $key;
croak 'data is required' if !defined $data;
my $url = $self->_endpoint( $bucket, $key );
my %headers;
$headers{'Content-Type'} = $options{content_type} // 'application/octet-stream';
# x-amz-acl header
if ( $options{acl} ) {
$headers{'x-amz-acl'} = $options{acl};
}
# User metadata — prefix bare keys with x-amz-meta-
if ( my $meta = $options{metadata} ) {
for my $k ( keys %{$meta} ) {
my $header = $k =~ /^x-amz-meta-/xsm ? $k : "x-amz-meta-$k";
$headers{$header} = $meta->{$k};
}
}
my $body;
if ( openhandle($data) || ( blessed($data) && $data->can('read') ) ) {
# --- Filehandle path ---
my $content_length = $options{content_length};
# Try to stat the handle for real files; suppress warning on
# in-memory handles (IO::Scalar etc.) that have no underlying fd
if ( !defined $content_length ) {
my $fd = eval { fileno($data) };
if ( defined $fd && $fd >= 0 ) {
my @st = stat $data;
$content_length = $st[7] if @st && defined $st[7];
}
}
croak 'content_length is required for in-memory filehandles'
if !defined $content_length;
$headers{'Content-Length'} = $content_length;
# Wrap filehandle in a code ref for HTTP::Tiny streaming
my $chunk_size = 1024 * 64; # 64KB chunks
$body = sub {
my $buf;
my $n = read( $data, $buf, $chunk_size );
return $buf if $n;
return q{};
};
}
elsif ( ref $data eq 'SCALAR' ) {
# --- Scalar ref path ---
$body = ${$data};
$headers{'Content-Length'} = length $body;
$headers{'Content-MD5'} = encode_base64( md5($body), q{} );
}
else {
# --- Plain scalar path ---
$body = $data;
$headers{'Content-Length'} = length $body;
$headers{'Content-MD5'} = encode_base64( md5($body), q{} );
}
my $response = $self->_request( 'PUT', $url, \%headers, $body );
$self->_croak_on_error( $response, 'put_object' );
my $etag = $response->{headers}{etag};
$etag =~ s/\A"|"\z//gxsm if defined $etag;
return $etag;
}
########################################################################
# list_objects_v2( $bucket, %options )
#
# Lists objects in a bucket using the S3 ListObjectsV2 API.
# Returns a hashref with keys: bucket, prefix, key_count, max_keys,
# is_truncated, next_continuation_token, objects, common_prefixes.
########################################################################
sub list_objects_v2 {
########################################################################
my ( $self, $bucket, %options ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
# Map our option names to S3 query parameter names
my %param_map = (
prefix => 'prefix',
delimiter => 'delimiter',
max_keys => 'max-keys',
continuation_token => 'continuation-token',
start_after => 'start-after',
);
my %params = ( 'list-type' => '2' );
for my $opt ( keys %param_map ) {
if ( defined $options{$opt} ) {
$params{ $param_map{$opt} } = $options{$opt};
}
}
# Build query string
my $query = join q{&}, map { uri_escape_utf8($_) . q{=} . uri_escape_utf8( $params{$_} ) }
sort keys %params;
my $url = $self->_endpoint($bucket) . q{?} . $query;
my $response = $self->_request( 'GET', $url );
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'list_objects_v2' );
return $self->_parse_list_objects_v2( $response->{content} );
}
########################################################################
# Parse the XML body of a ListObjectsV2 response
########################################################################
########################################################################
sub _parse_list_objects_v2 {
########################################################################
my ( $self, $xml ) = @_;
my ( @objects, @common_prefixes );
my ( $bucket, $prefix, $key_count, $max_keys, $is_truncated, $next_token );
XML::Twig->new(
twig_handlers => {
'Name' => sub { $bucket = $_[1]->text },
'ListBucketResult/Prefix' => sub { $prefix = $_[1]->text },
'KeyCount' => sub { $key_count = $_[1]->text + 0 },
'MaxKeys' => sub { $max_keys = $_[1]->text + 0 },
'IsTruncated' => sub { $is_truncated = $_[1]->text eq 'true' ? 1 : 0 },
'NextContinuationToken' => sub { $next_token = $_[1]->text },
'Contents' => sub {
my ( $t, $node ) = @_;
my $etag = $node->first_child_text('ETag') // q{};
$etag =~ s/\A"|"\z//gxsm;
push @objects,
{
key => $node->first_child_text('Key'),
size => $node->first_child_text('Size') + 0,
last_modified => $node->first_child_text('LastModified'),
etag => $etag,
storage_class => $node->first_child_text('StorageClass'),
};
$t->purge; # free memory as we go - important for large listings
},
'CommonPrefixes' => sub {
my ( $t, $node ) = @_;
push @common_prefixes, $node->first_child_text('Prefix');
},
}
)->parse($xml);
return {
bucket => $bucket,
prefix => $prefix,
key_count => $key_count,
max_keys => $max_keys,
is_truncated => $is_truncated,
next_continuation_token => $next_token,
objects => \@objects,
common_prefixes => \@common_prefixes,
};
}
########################################################################
# list_all_objects_v2( $bucket, %options )
#
# Convenience wrapper that auto-paginates list_objects_v2 and returns
# a flat list of all matching object hashrefs.
# delimiter is ignored — use list_objects_v2 directly for that.
########################################################################
sub list_all_objects_v2 {
########################################################################
my ( $self, $bucket, %options ) = @_;
# delimiter is meaningless here — silently remove it
delete $options{delimiter};
my @all_objects;
my $continuation_token;
while ($TRUE) {
if ( defined $continuation_token ) {
$options{continuation_token} = $continuation_token;
}
my $result = $self->list_objects_v2( $bucket, %options );
last if !$result; # 404 / empty bucket
push @all_objects, @{ $result->{objects} };
last if !$result->{is_truncated};
$continuation_token = $result->{next_continuation_token};
}
return @all_objects;
}
########################################################################
sub put_bucket_notification_configuration {
########################################################################
my ( $self, $bucket, %options ) = @_;
my $xml = $self->_create_notification_configuration( $bucket, %options );
my $url = $self->_endpoint($bucket) . q{?notification=};
my %headers = (
'Content-Type' => 'application/xml',
'Content-Length' => length $xml,
'Content-MD5' => encode_base64( md5($xml), q{} ),
);
my $response = $self->_request( 'PUT', $url, \%headers, $xml );
$self->_croak_on_error( $response, 'put_bucket_notification_configuration' );
return $TRUE;
}
########################################################################
sub put_public_access_block {
########################################################################
my ( $self, $bucket, %options ) = @_;
my $xml = $self->_create_public_access_block( $bucket, %options );
my $url = $self->_endpoint($bucket) . q{?publicAccessBlock=};
my %headers = (
'Content-Type' => 'application/xml',
'Content-Length' => length $xml,
'Content-MD5' => encode_base64( md5($xml), q{} ),
);
my $response = $self->_request( 'PUT', $url, \%headers, $xml );
$self->_croak_on_error( $response, 'put_public_access_block' );
return $TRUE;
}
########################################################################
sub remove_bucket_notification_configuration {
########################################################################
my ( $self, $bucket ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $xml = <<'END_XML';
<NotificationConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/"/>
END_XML
my $url = $self->_endpoint($bucket) . q{?notification=};
my %headers = (
'Content-Type' => 'application/xml',
'Content-Length' => length $xml,
'Content-MD5' => encode_base64( md5($xml), q{} ),
);
my $response = $self->_request( 'PUT', $url, \%headers, $xml );
$self->_croak_on_error( $response, 'remove_bucket_notification_configuration' );
return $TRUE;
}
########################################################################
sub get_bucket_notification_configuration {
########################################################################
my ( $self, $bucket ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $url = $self->_endpoint($bucket) . q{?notification=};
my $response = $self->_request( 'GET', $url );
$self->_croak_on_error( $response, 'get_bucket_notification_configuration' );
my $rsp = $self->_parse_notification_configuration( $response->{content} );
$self->logger->debug(
Dumper(
[ response => $response,
parsed_response => $rsp
]
)
);
return $rsp;
}
########################################################################
sub _parse_notification_configuration {
########################################################################
my ( $self, $xml ) = @_;
my @configs;
my $handler = sub {
my ( $t, $node ) = @_;
my @events = map { $_->text } $node->children('Event');
my @filter_rules;
if ( my $filter = $node->first_child('Filter') ) {
if ( my $s3key = $filter->first_child('S3Key') ) {
for my $rule ( $s3key->children('FilterRule') ) {
push @filter_rules,
{
name => $rule->first_child_text('Name'),
value => $rule->first_child_text('Value'),
};
}
}
}
push @configs,
{
id => $node->first_child_text('Id'),
lambda_arn => $node->first_child_text('CloudFunction'),
queue_arn => $node->first_child_text('Queue'),
topic_arn => $node->first_child_text('Topic'),
events => \@events,
filters => \@filter_rules,
};
$t->purge;
};
XML::Twig->new(
twig_handlers => {
CloudFunctionConfiguration => $handler,
lib/Amazon/S3/Lite.pm view on Meta::CPAN
my @event_xml;
foreach ( @{$events} ) {
push @event_xml, $self->_resolve( $templates->{event}, event => $_ );
}
my @filter_rules;
foreach my $p ( pairs %{ $options{filters} // {} } ) {
my ( $name, $value ) = @{$p};
push @filter_rules, $self->_resolve( $templates->{'filter-rule'}, filter_name => $name, filter => $value );
}
my $filters = @filter_rules ? $self->_resolve( $templates->{'filters'}, filter_rules => "@filter_rules" ) : q{};
my $xml = $templates->{ $options{type} . '-event' };
my $resolved_xml = $self->_resolve(
$xml,
id => $id,
lambda_arn => $options{lambda_arn},
queue_arn => $options{queue_arn},
events => "@event_xml",
filters => $filters,
);
$self->logger->debug( Dumper( [ resolved_xml => $resolved_xml ] ) );
return $resolved_xml;
}
########################################################################
sub _create_public_access_block {
########################################################################
my ( $self, $bucket, %permissions ) = @_;
croak 'ERROR: bucket is required'
if !defined $bucket || !length $bucket;
foreach my $p (qw(block_public_acls ignore_public_acls block_public_policy restrict_public_buckets)) {
$permissions{$p} = defined $permissions{$p} ? $permissions{$p} ? 'true' : 'false' : 'true';
}
my $templates = $self->_fetch_templates();
my $xml = $self->_resolve( $templates->{'public_access_block'}, %permissions );
$xml = qq{<?xml version="1.0" encoding="UTF-8"?>\n} . $xml;
$self->logger->debug( Dumper( [ xml => $xml ] ) );
return $xml;
}
########################################################################
sub put_bucket_website {
########################################################################
my ( $self, $bucket, %options ) = @_;
my $xml = $self->_create_website_configuration( $bucket, %options );
my $url = $self->_endpoint($bucket) . q{?website=};
my %headers = (
'Content-Type' => 'application/xml',
'Content-Length' => length $xml,
'Content-MD5' => encode_base64( md5($xml), q{} ),
);
my $response = $self->_request( 'PUT', $url, \%headers, $xml );
$self->_croak_on_error( $response, 'put_bucket_website' );
return $TRUE;
}
########################################################################
# get_bucket_policy( $bucket )
#
# Returns undef if the bucket has no policy (404
# NoSuchBucketPolicy). Otherwise returns the policy as a decoded
# hashref; pass raw => 1 to get the JSON string instead.
########################################################################
sub get_bucket_policy {
########################################################################
my ( $self, $bucket, %options ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $url = $self->_endpoint($bucket) . q{?policy=};
my $response = $self->_request( 'GET', $url );
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'get_bucket_policy' );
return $options{raw} ? $response->{content} : JSON::PP::decode_json( $response->{content} );
}
########################################################################
sub _create_website_configuration {
########################################################################
my ( $self, $bucket, %options ) = @_;
croak 'ERROR: bucket is required'
if !defined $bucket || !length $bucket;
my $index = $options{index} // 'index.html';
my $templates = $self->_fetch_templates;
my $error = q{};
if ( defined $options{error} && length $options{error} ) {
$error = $self->_resolve( $templates->{'website-error'}, error_key => $options{error} );
}
return $self->_resolve(
$templates->{website},
index => $index,
error => $error,
);
}
########################################################################
sub _parse_website_configuration {
########################################################################
my ( $self, $xml ) = @_;
my $root = XML::Twig->new->parse($xml)->root;
my %config;
if ( my $index = $root->first_child('IndexDocument') ) {
$config{index_document} = $index->first_child_text('Suffix');
}
if ( my $error = $root->first_child('ErrorDocument') ) {
$config{error_document} = $error->first_child_text('Key');
}
if ( my $redirect = $root->first_child('RedirectAllRequestsTo') ) {
$config{redirect_all_requests_to} = $redirect->first_child_text('HostName');
}
return \%config;
}
########################################################################
# get_bucket_website( $bucket )
#
# Returns undef if the bucket has no website configuration (404).
# Otherwise returns a hashref with index_document, error_document,
# and (if present) redirect_all_requests_to.
########################################################################
sub get_bucket_website {
########################################################################
my ( $self, $bucket ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $url = $self->_endpoint($bucket) . q{?website=};
my $response = $self->_request( 'GET', $url );
return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
if _is_not_found($response);
$self->_croak_on_error( $response, 'get_bucket_website' );
return $self->_parse_website_configuration( $response->{content} );
}
########################################################################
sub delete_bucket_website {
########################################################################
my ( $self, $bucket ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
my $url = $self->_endpoint($bucket) . q{?website=};
my $response = $self->_request( 'DELETE', $url );
$self->_croak_on_error( $response, 'delete_bucket_website' );
return $TRUE;
}
########################################################################
sub put_bucket_policy {
########################################################################
my ( $self, $bucket, $policy ) = @_;
croak 'bucket is required'
if !defined $bucket || !length $bucket;
croak 'policy is required'
if !defined $policy;
require JSON::PP;
my $json = ref $policy ? JSON::PP->new->canonical->encode($policy) : $policy;
my $url = $self->_endpoint($bucket) . q{?policy=};
my %headers = (
'Content-Type' => 'application/json',
'Content-Length' => length $json,
'Content-MD5' => encode_base64( md5($json), q{} ),
);
my $response = $self->_request( 'PUT', $url, \%headers, $json );
$self->_croak_on_error( $response, 'put_bucket_policy' );
return $TRUE;
}
my %TEMPLATES;
########################################################################
sub _fetch_templates {
########################################################################
my ($self) = @_;
return \%TEMPLATES
if %TEMPLATES;
local $RS = undef;
my $data = <DATA>;
$data =~ s/\A(.*?)^=pod.*\z/$1/xsm;
my $t = q{};
my $template_name = q{};
foreach my $line ( split /\n/xsm, $data ) {
if ( $line =~ /^:(.*)$/xsm ) {
if ( $template_name && $t ) {
$TEMPLATES{$template_name} = $t;
}
$t = q{};
$template_name = $1;
next;
}
$t .= "$line\n";
}
$TEMPLATES{$template_name} = $t;
return \%TEMPLATES;
}
########################################################################
sub _resolve {
########################################################################
my ( $self, $template, %data ) = @_;
my $output = $template;
foreach my $p ( pairs %data ) {
my ( $k, $v ) = @{$p};
lib/Amazon/S3/Lite.pm view on Meta::CPAN
has first-class support for Lambda IAM role credential rotation. If
you need the broader feature set or prefer direct HTTP access,
C<Amazon::S3::Thin> is a fine choice.
=head1 CONSTRUCTOR
=head2 new
my $s3 = Amazon::S3::Lite->new(\%options);
Returns a new C<Amazon::S3::Lite> object. Options:
=over 4
=item region (options, default: us-east-1)
The AWS region for your bucket, e.g. C<us-east-1>.
=item aws_access_key_id / aws_secret_access_key
Static credentials. C<token> may also be supplied for STS temporary
credentials (as used by Lambda execution roles).
These are only consulted if no C<credentials> object is provided.
=item token
Optional STS session token, used alongside static credentials for
temporary credential sets.
=item credentials
An object providing credential getters. The object must respond to:
$creds->aws_access_key_id
$creds->aws_secret_access_key
$creds->token # may return undef
Any object that satisfies this interface is accepted -
L<Amazon::Credentials>, L<Paws::Credential::*>, or your own. The
getters are called at request time, so objects that refresh expiring
credentials transparently are supported.
=item logger
An object providing the standard log methods:
$logger->trace(...)
$logger->debug(...)
$logger->info(...)
$logger->warn(...)
$logger->error(...)
If not supplied, the module looks for L<Log::Log4perl>. If available,
it calls C<Log::Log4perl::easy_init> with the configure log level (or
WARN) and logs to STDERR. If Log::Log4perl is not installed, a
minimal internal logger.
=item host
Override the S3 endpoint host. Defaults to C<s3.amazonaws.com>.
Useful for S3-compatible services (MinIO, Ceph, LocalStack).
=item secure
Use HTTPS. Default is 1 (true). Set to 0 only for testing against
local S3-compatible endpoints.
=item timeout
HTTP request timeout in seconds. Default is 30.
=back
=head2 Credential resolution order
When no C<credentials> object is passed, credentials are resolved in
this order:
=over 4
=item 1.
Constructor arguments C<aws_access_key_id> and C<aws_secret_access_key>.
=item 2.
Environment variables C<AWS_ACCESS_KEY_ID>, C<AWS_SECRET_ACCESS_KEY>,
and optionally C<AWS_SESSION_TOKEN>.
=item 3.
L<Amazon::Credentials>, if installed. This covers IAM instance roles,
Lambda execution roles, ECS task roles, and C<~/.aws/credentials>
profiles.
=item 4.
If none of the above yield credentials, the constructor croaks.
=back
=head1 METHODS
All methods croak on unrecoverable errors (network failure, HTTP 5xx).
HTTP 404 is not an exception - methods that can meaningfully return
C<undef> for a missing resource do so.
=head2 list_objects_v2
my $result = $s3->list_objects_v2($bucket, %options);
Lists objects in C<$bucket> using the S3 ListObjectsV2 API.
Options:
=over 4
=item prefix
Limit results to keys beginning with this string.
=item delimiter
Group keys sharing a common prefix up to this delimiter. Grouped
prefixes are returned in C<common_prefixes>.
lib/Amazon/S3/Lite.pm view on Meta::CPAN
omitted for that region as including it causes a C<InvalidLocationConstraint>
error. For all other regions the C<LocationConstraint> element is
sent automatically.
=item acl
Canned ACL string, e.g. C<private> (the S3 default), C<public-read>.
=back
Returns true on success. Croaks on failure.
=head2 delete_bucket
$s3->delete_bucket($bucket);
$s3->delete_bucket($bucket, region => 'us-west-2');
Deletes an empty bucket. Returns a true value on success. S3 refuses
to delete a bucket that still contains objects, so callers must empty
the bucket first (for example by iterating L</list_all_objects_v2> and
calling L</delete_object> on each key).
=over 4
=item region
Override the region the delete is signed against. Defaults to the
region the object was constructed with.
=back
=head2 put_public_access_block
$s3->put_public_access_block($bucket);
$s3->put_public_access_block(
$bucket,
block_public_acls => 1,
ignore_public_acls => 1,
block_public_policy => 0,
restrict_public_buckets => 0,
);
Sets the Block Public Access configuration on a bucket. Each of the
four settings is a boolean; any setting not supplied B<defaults to
true> (fully locked down), so an argument-less call blocks all public
access. Returns a true value on success.
=over 4
=item block_public_acls
=item ignore_public_acls
=item block_public_policy
=item restrict_public_buckets
Each accepts a true/false value. Omitted settings default to true.
Note that hosting content publicly (for example a static website, or
a policy-scoped private bucket that grants anonymous C<GetObject> from
a VPC endpoint) requires the relevant setting to be false so the
bucket policy is not rejected.
=back
=head2 put_bucket_website
$s3->put_bucket_website($bucket);
$s3->put_bucket_website($bucket, index => 'index.html', error => 'error.html');
Configures the bucket as an S3 static website endpoint. Returns a true
value on success.
=over 4
=item index
The index document suffix. Defaults to C<index.html>.
=item error
The error document key. Optional; when omitted, no error document is
configured.
=back
=head2 get_bucket_website
my $config = $s3->get_bucket_website($bucket);
Returns the bucket's website configuration as a hashref, or C<undef>
if the bucket has no website configuration. The hashref contains
whichever of the following are set:
=over 4
=item index_document
The index document suffix.
=item error_document
The error document key.
=item redirect_all_requests_to
The hostname all requests are redirected to, if the bucket is
configured as a redirect.
=back
=head2 delete_bucket_website
$s3->delete_bucket_website($bucket);
Removes the website configuration from a bucket. Returns a true value
on success.
=head2 put_bucket_policy
$s3->put_bucket_policy($bucket, \%policy);
$s3->put_bucket_policy($bucket, $json_string);
Attaches a bucket policy. The policy may be given either as a Perl
data structure (a hashref, which is encoded to canonical JSON) or as a
pre-encoded JSON string. Returns a true value on success.
=head2 get_bucket_policy
my $policy = $s3->get_bucket_policy($bucket);
my $json = $s3->get_bucket_policy($bucket, raw => 1);
lib/Amazon/S3/Lite.pm view on Meta::CPAN
Methods croak on:
=over 4
=item * Network-level failures (connection refused, timeout, DNS failure)
=item * HTTP 5xx responses from S3
=item * Unexpected HTTP 3xx responses that could not be resolved
=back
Methods return C<undef> on:
=over 4
=item * HTTP 404 (key or bucket not found), where the return type allows it
=back
All other HTTP error codes (400, 403, 409, etc.) cause a croak with a
message containing the HTTP status line and the S3 error body where
available.
=head1 DEPENDENCIES
=over 4
=item * L<HTTP::Tiny> (core since Perl 5.14)
=item * L<Amazon::Signature4::Lite>
=item * L<XML::Twig> (for parsing list and copy responses)
=item * L<Digest::MD5> (core, for Content-MD5 headers)
=item * L<MIME::Base64> (core)
=item * L<URI::Escape>
=item * L<Carp> (core)
=back
Optional:
=over 4
=item * L<Amazon::Credentials> - automatic credential discovery from IAM
roles, ECS task roles, ~/.aws/credentials, and environment.
=item * L<Log::Log4perl> - structured logging; if present, used in
preference to the built-in minimal logger.
=back
=head1 LAMBDA USAGE NOTES
In a Lambda container, credentials come from the execution role via
the ECS credential provider endpoint (indicated by
C<AWS_CONTAINER_CREDENTIALS_RELATIVE_URI> in the environment).
L<Amazon::Credentials> handles this automatically when installed and
is the recommended approach. If you prefer not to take that
dependency, the Lambda runtime also populates C<AWS_ACCESS_KEY_ID>,
C<AWS_SECRET_ACCESS_KEY>, and C<AWS_SESSION_TOKEN> directly, which
this module picks up automatically from the environment.
B<Region note:> The C<list_buckets> method is a global S3 operation
and is always signed against C<us-east-1>, regardless of the region
supplied to the constructor. This is an S3 requirement, not a
limitation of this module, and is handled transparently - your
object's region is not changed.
B<Cold start:> Because this module depends only on L<HTTP::Tiny> (Perl
core), L<XML::Twig>, L<AWS::Signature4>, and L<URI::Escape>, it adds
minimal overhead to Lambda container image builds compared to
LWP-based S3 clients.
=head1 TESTING
When testing against LocalStack, be aware that LocalStack is more
lenient than real S3 regarding SigV4 requirements. In particular,
LocalStack may accept requests where the C<x-amz-content-sha256>
header is missing or where session token handling is incorrect. Tests
that pass against LocalStack should always be verified against real S3
before release.
=head1 SEE ALSO
L<Amazon::S3> - the full-featured S3 client this module draws from
L<Amazon::S3::Thin> - another excellent lightweight S3 client with a
similar philosophy, broader feature coverage, and a longer track
record. Uses LWP by default and returns raw L<HTTP::Response>
objects. See L</DESCRIPTION> for a detailed comparison.
L<Net::Amazon::S3> - a Moose-based full-featured alternative
L<Amazon::Signature4::Lite> - the signing module used internally
L<Amazon::Credentials> - credential provider with IAM role and profile
support
=head1 AUTHOR
Rob Lauer <rlauer@treasurersbriefcase.com>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
( run in 1.370 second using v1.01-cache-2.11-cpan-364913b4093 )