package Net::Amazon::Signature::V4;

use 5.10.0;
use strict;
use warnings;
use sort 'stable';

use Digest::SHA qw/sha256_hex hmac_sha256 hmac_sha256_hex/;
use DateTime::Format::Strptime qw/strptime/;
use Data::Dumper;
use URI::Escape;

our $ALGORITHM = 'AWS4-HMAC-SHA256';

=head1 NAME

Net::Amazon::Signature::V4 - Implements the Amazon Web Services signature version 4, AWS4-HMAC-SHA256

=head1 VERSION

Version 0.13

=cut

our $VERSION = '0.13';


=head1 SYNOPSIS

This module signs an HTTP::Request to Amazon Web Services by appending an Authorization header. Amazon Web Services signature version 4, AWS4-HMAC-SHA256, is used.

    use Net::Amazon::Signature::V4;

    my $sig = Net::Amazon::Signature::V4->new( $access_key_id, $secret, $endpoint, $service );
    my $req = HTTP::Request->parse( $request_string );
    my $signed_req = $sig->sign( $req );
    ...

The primary purpose of this module is to be used by Net::Amazon::Glacier.

=head1 METHODS

=head2 new( $access_key_id, $secret, $endpoint, $service )

Constructs the signature object, which is used to sign requests.

Note that the access key ID is an alphanumeric string, not your account ID. The endpoint could be "eu-west-1", and the service could be "glacier".

=cut

sub new {
	my $class = shift;
	my ( $access_key_id, $secret, $endpoint, $service ) = @_;
	my $self = {
		access_key_id => $access_key_id,
		secret        => $secret,
		endpoint      => $endpoint,
		service       => $service,
	};
	bless $self, $class;
	return $self;
}

=head2 sign( $request )

Signs a request with your credentials by appending the Authorization header. $request should be an HTTP::Request. The signed request is returned.

=cut

sub sign {
	my ( $self, $request ) = @_;
	my $authz = $self->_authorization( $request );
	$request->header( Authorization => $authz );
	return $request;
}

# _canonical_request:
# Construct the canonical request string from an HTTP::Request.

sub _canonical_request {
	my ( $self, $req ) = @_;

	my $creq_method = $req->method;

	my ( $creq_canonical_uri, $creq_canonical_query_string ) = 
		( $req->uri =~ m@(.*?)\?(.*)$@ )
		? ( $1, $2 )
		: ( $req->uri, '' );
	$creq_canonical_uri =~ s@^https?://.*?/@/@;
	$creq_canonical_uri = _simplify_uri( $creq_canonical_uri );
	$creq_canonical_query_string = _sort_query_string( $creq_canonical_query_string );

	my @sorted_headers = sort { lc($a) cmp lc($b) } $req->headers->header_field_names;
	my $creq_canonical_headers = join '',
		map {
			sprintf "%s:%s\n",
				lc,
				join ',', sort {$a cmp $b } _trim_whitespace($req->header($_) )
		}
		@sorted_headers;
	my $creq_signed_headers = join ';', map {lc} @sorted_headers;
	my $creq_payload_hash = sha256_hex( $req->content );

	my $creq = join "\n",
		$creq_method, $creq_canonical_uri, $creq_canonical_query_string,
		$creq_canonical_headers, $creq_signed_headers, $creq_payload_hash;
	return $creq;
}

# _string_to_sign
# Construct the string to sign.

sub _string_to_sign {
	my ( $self, $req ) = @_;
	my $dt = _str_to_datetime( $req->header('Date') );
	my $creq = $self->_canonical_request($req);
	my $sts_request_date = $dt->strftime( '%Y%m%dT%H%M%SZ' );
	my $sts_credential_scope = join '/', $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request';
	my $sts_creq_hash = sha256_hex( $creq );

	my $sts = join "\n", $ALGORITHM, $sts_request_date, $sts_credential_scope, $sts_creq_hash;
	return $sts;
}

# _authorization
# Construct the authorization string

sub _authorization {
	my ( $self, $req ) = @_;

	my $dt = _str_to_datetime( $req->header('Date') );
	my $sts = $self->_string_to_sign( $req );
	my $k_date    = hmac_sha256( $dt->strftime('%Y%m%d'), 'AWS4' . $self->{secret} );
	my $k_region  = hmac_sha256( $self->{endpoint},        $k_date    );
	my $k_service = hmac_sha256( $self->{service},         $k_region  );
	my $k_signing = hmac_sha256( 'aws4_request',           $k_service );

	my $authz_signature = hmac_sha256_hex( $sts, $k_signing );
	my $authz_credential = join '/', $self->{access_key_id}, $dt->strftime('%Y%m%d'), $self->{endpoint}, $self->{service}, 'aws4_request';
	my $authz_signed_headers = join ';', sort { $a cmp $b } map { lc } $req->headers->header_field_names;

	my $authz = "$ALGORITHM Credential=$authz_credential, SignedHeaders=$authz_signed_headers, Signature=$authz_signature";
	return $authz;

}

=head1 AUTHOR

Tim Nordenfur, C<< <tim at gurka.se> >>

=cut

sub _simplify_uri {
	my $orig_uri = shift;
	my @parts = split /\//, $orig_uri;
	my @simple_parts = ();
	for my $part ( @parts ) {
		if ( ! $part || $part eq '.' ) {
		} elsif ( $part eq '..' ) {
			pop @simple_parts;
		} else {
			push @simple_parts, $part;
		}
	}
	my $simple_uri = '/' . join '/', @simple_parts;
	$simple_uri .= '/' if $orig_uri =~ m@/$@ && $simple_uri !~ m@/$@;
	return $simple_uri;
}
sub _sort_query_string {
	return '' unless $_[0];
	my @params;
	for my $param ( split /&/, $_[0] ) {
		my ( $key, $value ) = 
			map { tr/+/ /; uri_escape( uri_unescape( $_ ) ) } # escape all non-unreserved chars
			split /=/, $param;
		push @params, join '=', $key, ($value//'');
	}
	return join '&',
		#sort { $a cmp $b }
		sort {
			my ( $a_key, $a_val ) = _key_val_split($a);
			my ( $b_key, $b_val ) = _key_val_split($b);
			( $a_key cmp $b_key ) || ( $a_val cmp $b_val );
		}
		@params;
	my $sorted_query_string = 
		join '&',
		sort { $a cmp $b }
		map { $_ . (m/=/?'':'=') } # for empty values
		split /&/,
		$_[0];
}
sub _key_val_split {
	my ( $key, $val ) = ( $_[0] =~ m/^([^=]+)=(.*)$/ );
	return ( $key, $val );
}
sub _trim_whitespace {
	return map { s/^\s*(.*?)\s*$/$1/; $_ } @_;
}
sub _str_to_datetime {
	my $date = shift;
	if ( $date =~ m/^\d{8}T\d{6}Z$/ ) {
		# assume basic ISO 8601, as demanded by AWS
		return strptime( '%Y%m%dT%H%M%SZ', $date );
	} else {
		# assume the format given in the AWS4 test suite
		$date =~ s/^.{4}//; # remove weekday, as Amazon's test suite contains internally inconsistent dates
		return strptime(  '%d %b %Y %H:%M:%S %Z', $date );
	}
}

=head1 BUGS

Please report any bugs or feature requests to C<bug-net-amazon-signature-v4 at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Amazon-Signature-V4>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::Amazon::Signature::V4


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Amazon-Signature-V4>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-Amazon-Signature-V4>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-Amazon-Signature-V4>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-Amazon-Signature-V4/>

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Tim Nordenfur.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Net::Amazon::Signature::V4