File Coverage

blib/lib/Amazon/Signature4/Lite.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	18	18	100.0
condition	17	24	70.8
subroutine	10	10	100.0
pod	3	3	100.0
total	124	131	94.6

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

our $VERSION = '1.0.0';

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

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

  $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,
    'x-amz-date'           => $datetime,
    'x-amz-content-sha256' => $payload_hash,
  );

  $sign_headers{'x-amz-security-token'} = $self->{session_token}
    if $self->{session_token};

  # sort and build canonical headers string
  my @header_keys    = sort { lc($a) cmp lc($b) } keys %sign_headers;
  my $canon_headers  = join q{}, map { lc($_) . ':' . $sign_headers{$_} . "\n" } @header_keys;
  my $signed_headers = join ';', map { lc($_) } @header_keys;

  # canonical query string - sort by encoded key then encoded value
  my $canon_query = q{};
  if ($query) {
    my @pairs = map {
      join '=', map { uri_escape_utf8($_) } split /=/xsm, $_, 2
      }
      sort { $a cmp $b }
      split /&/xsm, $query;
    $canon_query = join '&', @pairs;
  }

  # canonical request
  my $canon_request = join "\n", $method, _encode_path($path), $canon_query, $canon_headers, $signed_headers, $payload_hash;

  # credential scope
  my $service = $self->{service};
  my $region  = $self->{region};
  my $scope   = "$date/$region/$service/aws4_request";

  # string to sign
  my $string_to_sign = join "\n", 'AWS4-HMAC-SHA256', $datetime, $scope, sha256_hex($canon_request);

  # signing key - HMAC chain
  my $signing_key = hmac_sha256( 'aws4_request',
    hmac_sha256( $service, hmac_sha256( $region, hmac_sha256( $date, "AWS4${\$self->{secret_key}}" ) ) ) );

  # signature
  my $signature = hmac_sha256_hex( $string_to_sign, $signing_key );

  # authorization header
  my $authorization = sprintf
    'AWS4-HMAC-SHA256 Credential=%s/%s, SignedHeaders=%s, Signature=%s',
    $self->{access_key}, $scope, $signed_headers, $signature;

  # return merged headers ready for HTTP::Tiny
  return { %sign_headers, 'Authorization' => $authorization, };
}

########################################################################
sub _encode_path {
########################################################################
  my ($path) = @_;

  # encode each segment individually, preserving slashes
  return join '/', map { uri_escape_utf8($_) } split m{/}xsm, $path, -1;
}

1;

__END__