• Your recent searches
Amazon-S3-Lite
8 results

 view release on metacpan or  search on metacpan

lib/Amazon/S3/Lite.pm  view on Meta::CPAN 

use strict;
use warnings;

use Amazon::Signature4::Lite;
use Amazon::S3::Lite::Credentials;
use Amazon::S3::Lite::Logger;
use Amazon::S3::Lite::Constants qw(:booleans);
use Carp qw(croak);
use Data::Dumper;
use Digest::MD5 qw(md5_base64 md5);
use Digest::SHA qw(sha256_hex);
use English qw(-no_match_vars);
use HTTP::Tiny;
use List::Util qw(pairs);
use MIME::Base64 qw(encode_base64);
use Scalar::Util qw(blessed openhandle reftype);
use URI::Escape qw(uri_escape_utf8);
use XML::Twig;
use JSON::PP;

use Role::Tiny::With;
with 'Amazon::S3::Lite::Policies';

our $VERSION = '1.3.3';

########################################################################
sub new {
########################################################################
  my ( $class, @args ) = @_;

  my $options = ref $args[0] ? $args[0] : {@args};

  my $self = bless $options, $class;

  $self->{host}    //= 's3.amazonaws.com';
  $self->{secure}  //= $TRUE;
  $self->{timeout} //= 30;
  $self->{region}  //= 'us-east-1';
  $self->{last_status} = q{};

  $self->_init_logger;
  $self->_init_credentials;
  $self->_init_ua;

  return $self;
}

########################################################################
# Logger setup
# Priority: caller-supplied object -> Log::Log4perl (if available) ->
#           minimal STDERR logger
########################################################################
sub _init_logger {
########################################################################
  my ($self) = @_;

  my $logger = $self->{logger};

  if ( $logger && blessed $logger ) {
    # Validate it quacks like a logger
    for my $method (qw(trace debug info warn error)) {
      croak "logger object must implement '$method'"
        if !$logger->can($method);
    }

    return;
  }

  my $log4perl = eval {
    require Log::Log4perl;
    1;
  };

  my $log_level = $self->{log_level} // 'warn';
  $self->{log_level} = $log_level;

  if ($log4perl) {
    if ( !Log::Log4perl->initialized ) {
      Log::Log4perl->easy_init( { level => uc $log_level } );
    }

    $self->{logger} = Log::Log4perl->get_logger(__PACKAGE__);
    return;
  }

  # Fall back to minimal STDERR logger
  $self->{logger} = Amazon::S3::Lite::Logger->new( log_level => $log_level );

  return;
}

########################################################################
# Credential resolution
# Priority: explicit credentials object -> constructor args ->
#           environment variables -> Amazon::Credentials (if available)
########################################################################
sub _init_credentials {
########################################################################
  my ($self) = @_;

  # 1. Caller-supplied credentials object (duck-typed)
  if ( my $creds = $self->{credentials} ) {
    croak "credential object is not blessed.\n"
      if !blessed $creds;

    foreach (qw(aws_access_key_id aws_secret_access_key token)) {
      my $sub = $creds->can($_) // $creds->can("get_$_");

      croak "credentials object must implement $_ or get_$_\n"
        if !$sub;
    }

    $self->{credentials} = $creds;

    return;
  }

  # 2. Explicit constructor args
  if ( $self->{aws_access_key_id} && $self->{aws_secret_access_key} ) {
    $self->{credentials} = Amazon::S3::Lite::Credentials->new(
      aws_access_key_id     => delete $self->{aws_access_key_id},

lib/Amazon/S3/Lite.pm  view on Meta::CPAN 

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";

  if ( defined $bucket && length $bucket ) {
    $url .= "/$bucket";
  }

  if ( defined $key && length $key ) {
    $url .= q{/} . _encode_key($key);
  }

  return $url;
}

########################################################################
# URI-encode an S3 key, preserving '/' separators
########################################################################
sub _encode_key {
########################################################################
  my ($key) = @_;

  return join q{/}, 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   //= {};

  $self->{last_status} = q{};

  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,
    payload_hash => $extra->{payload_hash},
  );

  # 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} );

  $self->{last_status} = $response->{status};

  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};

  if ( defined $etag ) {
    $etag =~ s/\A"|"\z//gxsm;
  }

  # 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,

lib/Amazon/S3/Lite.pm  view on Meta::CPAN 

  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,
      QueueConfiguration         => $handler,
      TopicConfiguration         => $handler,
    }
  )->parse($xml);

  return \@configs;
}

########################################################################
sub _create_notification_configuration {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  croak 'ERROR: bucket is required'
    if !defined $bucket || !length $bucket;

  croak "ERROR: type is a required argument\n"
    if !$options{type};

  croak 'ERROR: lambda_arn is required'
    if $options{type} eq 'lambda' && !$options{lambda_arn};

  croak 'ERROR: queue_arn is required'
    if $options{type} eq 'sqs' && !$options{queue_arn};

  my $events = ref $options{events} ? $options{events} : [ $options{events} ];

  croak "ERROR: no events defined\n"
    if !$options{events} || !@{$events};

  my $templates = $self->_fetch_templates();

  my $id = $options{id} // 'notification-1';

  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;

lib/Amazon/S3/Lite.pm  view on Meta::CPAN 

support the full S3 API surface including multipart upload, bucket
management, ACLs, versioning, and presigned URLs. If you need those
features, use one of those distributions instead.

L<Amazon::S3::Thin> is another excellent lightweight S3 client with a
similar philosophy and a longer track record. It is more complete than
this module - supporting presigned URLs, bulk delete, and
virtual-hosted-style requests - and returns raw L<HTTP::Response>
objects so callers handle status codes and errors
themselves. C<Amazon::S3::Lite> differs in three ways: it has no
dependency on LWP (C<Amazon::S3::Thin> defaults to L<LWP::UserAgent>),
it returns parsed hashrefs rather than raw response objects, and it
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

lib/Amazon/S3/Lite.pm  view on Meta::CPAN 


=back

Returns a hashref:

  {
    bucket                 => 'my-bucket',
    prefix                 => 'logs/',
    is_truncated           => 0,
    next_continuation_token => undef,        # set when is_truncated is true
    key_count              => 42,
    objects                => [
      {
        key           => 'logs/2024-01-01.gz',
        size          => 102400,
        last_modified => '2024-01-01T00:00:00.000Z',
        etag          => 'abc123',
        storage_class => 'STANDARD',
      },
      ...
    ],
    common_prefixes        => [],            # populated when delimiter is set
  }

=head2 list_all_objects_v2

  my @objects = $s3->list_all_objects_v2($bucket, %options);

Convenience wrapper around L</list_objects_v2> that automatically
follows continuation tokens and returns a flat list of all matching
object hashrefs in a single call.

Accepts the same options as C<list_objects_v2> except
C<continuation_token> (which is managed internally) and C<delimiter>
(which is silently ignored - see below).

  my @logs = $s3->list_all_objects_v2('my-bucket', prefix => 'logs/');

  foreach my $obj (@logs) {
    printf "%s  %d bytes\n", $obj->{key}, $obj->{size};
  }

Be mindful of memory when listing buckets with large numbers of
objects.  For very large listings, use L</list_objects_v2> directly
and process each page as it arrives.

C<delimiter> and C<common_prefixes> are not supported by this method.
The purpose of C<list_all_objects_v2> is a complete flat listing of
all matching keys. Hierarchical directory-style traversal using
C<delimiter> is inherently page-by-page and should use
L</list_objects_v2> directly.

Returns a (possibly empty) list of object hashrefs, each with the same
fields as the elements of C<objects> in the C<list_objects_v2>
response.

=over 4

=item log_level

Log level for the internal logger. Accepted values: C<trace>, C<debug>,
C<info>, C<warn>, C<error>, C<fatal>. Default is C<warn>. Only consulted
when no C<logger> object is supplied and Log::Log4perl is not available
or not yet initialized.

=back

=head2 get_object

  my $obj = $s3->get_object($bucket, $key);
  my $obj = $s3->get_object($bucket, $key, %options);

Fetches the object at C<$key> in C<$bucket>.

Returns C<undef> if the key does not exist (HTTP 404).

Returns a hashref on success:

  {
    content        => '...',          # raw bytes; absent when filename is used
    content_type   => 'application/json',
    content_length => 1024,
    etag           => 'abc123',
    last_modified  => 'Tue, 01 Jan 2024 00:00:00 GMT',
    metadata       => {               # x-amz-meta-* headers, lowercased
      source => 'lambda',
    },
  }

Options:

=over 4

=item range

An HTTP Range header value, e.g. C<bytes=0-1023>, for partial fetches.

=item filename

Path to a local file where the object body should be written. When
supplied, the response body is streamed directly to disk via
HTTP::Tiny's C<:content_file> mechanism and C<content> is omitted from
the returned hashref. The file is created or overwritten.

  my $meta = $s3->get_object('my-bucket', 'data/dump.csv',
    filename => '/tmp/dump.csv',
  );
  # $meta->{content} is absent; file is on disk

This is the recommended approach for large objects in Lambda where
holding the full body in memory is undesirable.

=back

=head2 head_object

  my $meta = $s3->head_object($bucket, $key);

Fetches metadata for C<$key> without retrieving the object body.
Useful for existence checks and reading C<x-amz-meta-*> headers
cheaply.



( run in 1.895 second using v1.01-cache-2.11-cpan-062aa07a564 )