view release on metacpan or  search on metacpan

lib/DarkPAN/Indexer/Storage/S3.pm  view on Meta::CPAN

package DarkPAN::Indexer::Storage::S3;

# S3 storage engine for DarkPAN::Indexer.
#
# Consumes the DarkPAN::Indexer::Storage role (the contract). Wraps the
# four S3 primitives the old roles called directly:
#   list_objects_v2  -> list_distributions
#   get_object       -> fetch_object
#   head_object      -> has_object
#   put_object       -> save_object
#
use strict;
use warnings;

use Amazon::Credentials;
use Amazon::S3::Lite;
use Amazon::S3::Lite::Lock;
use Data::Dumper;
use Carp qw(croak);
use English qw(-no_match_vars);

use Role::Tiny::With;
with 'DarkPAN::Indexer::Storage';  # requires: list_distributions fetch_object
  #           save_object has_object lock base_url

caller or exit __PACKAGE__->main();

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

  # prefer storage keys over AWS
  my %storage = ( %{ $config->{AWS} // {} }, %{ $config->{storage} // {} } );
  $storage{region} //= $ENV{AWS_REGION} // 'us-east-1';

  $config->{storage} = \%storage;

  croak "S3 storage: bucket is required\n"
    if !defined $storage{bucket} || $storage{bucket} eq q{};

  my $self = bless {
    config   => $config,
    bucket   => $storage{bucket},
    prefix   => $storage{prefix},
    region   => $storage{region},
    profile  => $storage{profile},
    base_url => $config->{url},  # public (CloudFront) base
  }, $class;

  return $self;
}

########################################################################
sub _s3 {
########################################################################
  my ($self) = @_;

  return $self->{s3} //= Amazon::S3::Lite->new(
    { region      => $self->{region},
      credentials => Amazon::Credentials->new( profile => $self->{profile} ),
    }
  );
}

########################################################################
sub base_url { return $_[0]->{base_url} }
########################################################################

########################################################################
# list_distributions() -> list of keys (relative to the bucket) that
# look like distribution tarballs under the configured prefix. Paginates
# via continuation token. The .tar.gz filter lives here because "what
# counts as a distribution" is the one bit of domain knowledge this
# seam legitimately owns.
########################################################################
sub list_distributions {
########################################################################
  my ($self) = @_;

  my $s3 = $self->_s3;
  my @keys;
  my $token;

  while (1) {
    my %options = ( defined $self->{prefix} ? ( prefix => $self->{prefix} ) : () );

    if ( defined $token ) {
      $options{continuation_token} = $token;
    }

    my $result = $s3->list_objects_v2( $self->{bucket}, %options );

    for my $object ( @{ $result->{objects} || [] } ) {
      my $key = $object->{key};
      next if !defined $key;
      next if $key !~ m{[.]tar[.]gz\z}xsm;
      push @keys, $key;
    }

    last
      if !$result->{is_truncated};

    $token = $result->{next_continuation_token};
    last if !$token;
  }

  return @keys;
}

########################################################################
# fetch_object($key) -> raw bytes, or undef if genuinely absent.
# A real I/O failure throws (fail-fast contract).
########################################################################
sub fetch_object {
  my ( $self, $key ) = @_;

  my $object = $self->_s3->get_object( $self->{bucket}, $key );

  return
    if !defined $object;  # not found -> undef