File Coverage

blib/lib/WebService/Amazon/Signature/v4.pm

Criterion	Covered	Total	%
statement	143	166	86.1
branch	23	38	60.5
condition	5	11	45.4
subroutine	31	33	93.9
pod	13	13	100.0
total	215	261	82.3

package WebService::Amazon::Signature::v4;
$WebService::Amazon::Signature::v4::VERSION = '0.002';
use strict;
use warnings;

use parent qw(WebService::Amazon::Signature);

=head1 NAME

WebService::Amazon::Signature::v4 - support for v4 of the Amazon signing method

=head1 VERSION

version 0.002

=head1 SYNOPSIS

 my $req = 'GET / HTTP/1.1 ...';
 my $amz = WebService::Amazon::Signature::v4->new(
  scope      => '20110909/us-east-1/host/aws4_request',
  access_key => 'AKIDEXAMPLE',
  secret_key => 'wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY',
 );
 $amz->parse_request($req)
 my $signed_req = $amz->signed_request($req);

=head1 DESCRIPTION

=cut

use Time::Moment;
use POSIX qw(strftime);
use Digest::SHA qw(sha256 sha256_hex);
use Digest::HMAC qw(hmac hmac_hex);
use List::UtilsBy qw(sort_by);
use HTTP::StreamParser::Request;
use URI;
use URI::QueryParam;
use URI::Escape qw(uri_escape_utf8 uri_unescape);

use constant DEBUG => 0;

use Log::Any qw($log);

=head1 METHODS - Constructor

=cut

=head2 new

Instantiate a signing object. Expects the following named parameters:

=over 4

=item * scope - the scope used for requests, typically something like C<20130112/us-west-2/dynamodb/aws4_request>

=item * secret_key - your secret key

=item * access_key - your access key

=back

=cut

sub new {
	my $class = shift;
	bless {
		algorithm  => 'AWS4-HMAC-SHA256',
		@_
	}, $class
}

=head1 METHODS - Accessors

=head2 algorithm

Read-only accessor for the algorithm (default is C)

=cut

sub algorithm { shift->{algorithm} }

=head2 date

Read-only accessor for the date field.

=cut

sub date { shift->{date} }

=head2 scope

Read-only accessor for scope information - typically something like
C<20110909/us-east-1/host/aws4_request>.

=cut

sub scope { shift->{scope} }

=head2 access_key

Readonly accessor for the access key used when signing requests.

=cut

sub access_key { shift->{access_key} }

=head2 secret_key

Readonly accessor for the secret key used when signing requests.

=cut

sub secret_key { shift->{secret_key} }

=head2 signed_headers

Read-only accessor for the headers used for signing purposes
(a string consisting of the lowercase headers separated by ;
in lexical order)

=cut

sub signed_headers { shift->{signed_headers} }

=head1 METHODS

=head2 parse_request

Parses a given request. Takes a single parameter - the HTTP request as a string.

=cut

sub parse_request {
	my $self = shift;
	my $txt = shift;
	my $parser = HTTP::StreamParser::Request->new;
	my $method;
	my $uri;
	my %header;
	my @headers;
	my $payload = '';
	$parser->subscribe_to_event(
		http_method => sub { $method = $_[1] },
		http_uri    => sub { $uri = $_[1]; },
		http_header => sub {
			if(exists $header{lc $_[1]}) {
				$header{lc $_[1]} = [
					$header{lc $_[1]}
				] unless ref $header{lc $_[1]};
				push @{$header{lc $_[1]}}, $_[2]
			} else {
				$header{lc $_[1]} = $_[2]
			}
		},
		http_body_chunk => sub {
			$payload .= $_[1]
		}
	);
	$parser->parse($txt);
	$self->{headers} = \@headers;
	$self->{header} = \%header;
	$self->{method} = $method;
	$self->{uri} = $uri;
	$self->{payload} = $payload;
	$self
}

=head2 from_http_request

Parses information from an L instance.

=cut

sub from_http_request {
	my $self = shift;
	my $req = shift;
	$self->{method} = $req->method;
	$self->{uri} = '' . $req->uri;
	$self->{payload} = $req->content;
	my %header;
	$req->scan(sub {
		my ($k, $v) = @_;
		if(exists $header{lc $k}) {
			$header{lc $k} = [
				$header{lc $k}
			] unless ref $header{lc $k};
			push @{$header{lc $k}}, $v
		} else {
			$header{lc $k} = $v
		}
	});
	$self->{header} = \%header;
	$self
}

=head2 canonical_request

Returns the string form of the canonical request, used
as an intermediate point in generating the signature.

=cut

sub canonical_request {
	my $self = shift;

	my %header = %{$self->{header}};
	my $method = $self->{method};
	my $payload = $self->{payload};
	my $uri = $self->{uri};

	# Strip all leading/trailing whitespace from headers,
	# convert to canonical comma-separated format
	s/^\s+//, s/\s+$// for map @$_, grep ref($_), values %header;
	$_ = join ',', sort @$_ for grep ref($_), values %header;
	s/^\s+//, s/\s+$// for values %header;

	$uri =~ s{ .*$}{}g;
	$uri =~ s{#}{%23}g;

	# We're not actually connecting to this so a default
	# value should be safe here. Only used to ensure URI
	# detects this as an HTTP URI.
	$uri = 'http://localhost' . $uri if !length($uri) or $uri !~ /^https?:/;

	my $u = (ref $uri ? $uri : URI->new($uri))->clone->canonical;
	$uri = $u->path;
	my $path = '';
	while(length $uri) {
		if(substr($uri, 0, 3) eq '../') {
			substr $uri, 0, 3, '';
		} elsif(substr($uri, 0, 2) eq './') {
			substr $uri, 0, 2, '';
		} elsif(substr($uri, 0, 3) eq '/./') {
			substr $uri, 0, 3, '/';
		} elsif(substr($uri, 0, 4) eq '/../') {
			substr $uri, 0, 4, '/';
			$path =~ s{/?[^/]*$}{};
		} elsif(substr($uri, 0, 3) eq '/..') {
			substr $uri, 0, 3, '/';
			$path =~ s{/?[^/]*$}{};
		} elsif(substr($uri, 0, 2) eq '/.') {
			substr $uri, 0, 3, '/';
		} elsif($uri eq '.' or $uri eq '..') {
			$uri = '';
		} else {
			$path .= $1 if $uri =~ s{^(/?[^/]*)}{};
		}
	}
	$path =~ s{/+}{/}g;
	$u->path($path);
	my @query;
	if(length $u->query) {
		for my $qp (split /&/, $u->query) {
			my ($k, $v) = map uri_unescape($_), split /=/, $qp, 2;
			for ($k, $v) {
				$_ //= '';
				s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
				$_ = Encode::decode('UTF-8' => $_);
				s{\+}{ }g;
				$_ = uri_escape_utf8($_);
			}
			push @query, "$k=$_" for $v
		}
	}
	my $query = join '&', sort @query;

	# Now apply the date. This can come from various sources:
	# * X-Amz-Date:
	# * Date:
	# * Current date/time
	if(exists $header{'x-amz-date'}) {
		$self->{date} = $header{'x-amz-date'};
	} elsif(exists $header{'date'}) {
		eval {
			require Time::Piece;
			$self->{date} = Time::Piece->strptime($header{date}, '%a, %d %b %Y %H:%M:%S GMT')->strftime('%Y%m%dT%H%M%SZ');
		};
		# ignore $@, we'll fall through to default value on failure
	}
	# Worst-case scenario: apply a default value.
	$self->{date} ||= strftime '%Y%m%dT%H%M%SZ', gmtime;

	my $can_req = join "\n",
			$method,
			$path,
			$query;
	my @can_header = map { lc($_) . ':' . $header{$_} } sort_by { lc } keys %header;
	$can_req .= "\n" . join "\n", @can_header;
	$can_req .= "\n\n" . join ';', sort map lc, keys %header;
	$self->{signed_headers} = join ';', sort map lc, keys %header;
	$can_req .= "\n" . sha256_hex($payload);
	return $can_req;
}

=head2 string_to_sign

Returns the \n-separated string as the last step before
generating the signature itself.

=cut

sub string_to_sign {
	my $self = shift;
	my $can_req = $self->canonical_request;
	$log->debugf("Canonical request:\n%s", $can_req) if DEBUG;
	my $hashed = sha256_hex($can_req);
	$log->debugf("Hashed [%s]", $hashed) if DEBUG;
	my $to_sign = join "\n",
			$self->algorithm,
			$self->date,
			$self->scope,
			$hashed;
	$log->debugf("To sign:\n%s", $to_sign) if DEBUG;
	$to_sign
}

=head2 calculate_signature

Calculates the signature for the current request and returns it
as a string suitable for the C header.

=cut

sub calculate_signature {
	my $self = shift;
	die "No secret key" unless defined($self->secret_key);
	die "No scope" unless defined($self->scope);
	my $hmac = 'AWS4' . $self->secret_key;
	$hmac = hmac($_, $hmac, \&sha256) for split qr{/}, $self->scope;
	my $signature = hmac_hex($self->string_to_sign, $hmac, \&sha256);
	my $headers = $self->signed_headers;
	return $self->algorithm . ' Credential=' . $self->access_key . '/' . $self->scope . ', SignedHeaders=' . $headers . ', Signature=' . $signature;
}

=head2 signed_request

Returns a signed version of the request.

=cut

sub signed_request {
	my $self = shift;
	my $req = shift;
	my $signature = $self->calculate_signature;
	$req =~ s{\x0D\x0A\x0D\x0A}{\x0D\x0AAuthorization: $signature\x0D\x0A\x0D\x0A};
	$req
}

1;

__END__