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";
  my $headers           = $args{headers}           // {};
  my $payload           = $args{payload}           // q{};
  my $add_sha256_header = $args{add_sha256_header} // 1;

  # parse url into components
  my ( $scheme, $host, $path, $query ) = $url =~ m{\A(https?)://([^/?#]+)([^?#]*)(?:[?]([^#]*))?\z}xsm;

  $path = $path || '/';
  $query //= q{};

  # timestamps
  my $now      = $args{time} // time;
  my $datetime = strftime( '%Y%m%dT%H%M%SZ', gmtime($now) );
  my ($date)   = $datetime =~ /\A(\d{8})/xsm;

  # payload hash
  my $payload_hash = sha256_hex( ref $payload ? ${$payload} : $payload );

  # canonical headers - must include host and x-amz-date at minimum
  my %sign_headers = (
    %{$headers},
    'host'       => $host,