view release on metacpan or  search on metacpan

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

package Amazon::Signature4::Lite;

use strict;
use warnings;

use Digest::SHA qw(sha256_hex hmac_sha256 hmac_sha256_hex);
use MIME::Base64 qw(encode_base64);
use POSIX qw(strftime);
use URI::Escape qw(uri_escape_utf8 uri_unescape);
use Data::Dumper;

our $VERSION = '1.0.1';

my @SERVICE_URL_PATTERNS = (
  qr/(s3)[.]amazonaws[.]com\z/xsm,
  qr/(s3)[.]([^.]+)[.]amazonaws[.]com\z/xsm,
  qr/(s3)[.][^.]+[.]([^.]+)[.]amazonaws[.]com\z/xsm,
  qr/(s3)[-][^.]+[.].+[.]([^.]+)[.]amazonaws[.]com\z/xsm,
  qr/^([[:alnum:]-]+)[.]([^.]+)[.]amazonaws[.]com\z/xsm,  # service.region.amazonaws.com
  qr/^([[:alnum:]-]+)[.]amazonaws[.]com\z/xsm,  # service.amazonaws.com (no region)
);

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

  die "access_key is required\n" if !$args{access_key};
  die "secret_key is required\n" if !$args{secret_key};
  die "region is required\n"     if !$args{region};

  return bless {
    access_key    => $args{access_key},
    secret_key    => $args{secret_key},
    session_token => $args{session_token},
    region        => $args{region},
    service       => $args{service} // 's3',
  }, $class;
}

########################################################################
sub parse_service_url {
########################################################################
  my ( $class_or_self, %args ) = @_;

  my ( $host,   $service )        = @args{qw(host service)};
  my ( $region, $default_region ) = @args{qw(region default_region)};

  if ( !$service || !$region ) {
    for my $pattern (@SERVICE_URL_PATTERNS) {
      if ( $host =~ $pattern ) {
        $service = $1;
        $region  = $2 || $region || $default_region;
        last;
      }
    }
  }

  $region ||= $default_region;

  return ( $host, $service, $region );
}

########################################################################
sub sign {
########################################################################
  my ( $self, %args ) = @_;

  my $method            = uc( $args{method} // 'GET' );
  my $url               = $args{url} or die "url is required\n";