File Coverage

blib/lib/Net/Amazon/AWSSign.pm

Criterion	Covered	Total	%
statement	64	66	96.9
branch	7	14	50.0
condition			n/a
subroutine	12	12	100.0
pod	3	4	75.0
total	86	96	89.5

package Net::Amazon::AWSSign;

use 5.008;
use strict;
use warnings;

use vars qw($VERSION);
$VERSION = '0.12';

use MIME::Base64;
use Digest::SHA qw(hmac_sha256_base64);
use URI::Escape;


# General stuff
my $request;
my $SOAPAction;
my $SOAPTimestamp;
my @params;
my $finalString='';
my $finalParams='';
my $AWSSignature='';
my $finalRequestURL;
# My throwaway temp arrays
my @a;
my @b;
# My throwaway temp variables
my $z;
my $y;
# For the secret generator
my $requestProtocol;
my $requestHost;
my $requestPath;


## OO Subs
# Construct an object, called with your AWS key and secret
sub new
{
  my $class = shift;
  my $self = {
        _AWSKey => shift,
        _AWSSecret  => shift,
  };
  bless $self, $class;
  return $self;
}


sub addRESTSecret {
  my ($self, $request)=@_;
  unless ($request=~m/\&Timestamp=2/) {
  	$request=$request . "&Timestamp=" . &getAWSTimeStamp();
  }
  $finalString="GET\n";
  # Not sure why I thought this was important, but I probably had some rationale, so leaving it in here.
  if ($request=~m/^(http|https)?:\/\/(.*?)\/(.*?)\?/) {
	$requestProtocol="$1";
  	$requestHost="$2";
  	$requestPath="/$3";
  	$finalString=$finalString . "$2\n/$3\n";
  }else{
  	return "ERROR: Cannot determine hostname and base path of request";
  }
  # Get just the parameters
  @a=split(/\?/, $request, 2);
  # If we don't already have the subscription ID in the argument list, then add it.
  unless ($a[1]=~m/$self->{_AWSKey}/) { $a[1]="$a[1]&AWSAccessKeyId=$self->{_AWSKey}"; }
  # Ditto for the SHA version and Signature version
  unless ($a[1]=~m/HmacSHA256/) { $a[1]="$a[1]&SignatureMethod=HmacSHA256"; }
  unless ($a[1]=~m/SignatureVersion/) { $a[1]="$a[1]&SignatureVersion=2"; }

  @params=split(/\&/, $a[1]);
  # Sort and URI encode arguments, slam them into @b
  undef @b;
  foreach $z (sort @params) {
  	@a=split(/=/, $z, 2);
	# To allow for passing in url-encoded strings, we decode it then encode it
	$a[1]=URI::Escape::uri_unescape( "$a[1]");
  	$a[1]=URI::Escape::uri_escape( "$a[1]", "^A-Za-z0-9\-_.~" );
  	$z=join('=', @a);
  	push (@b, $z);
  }
  $finalString="$finalString" . join ('&', @b);

  $AWSSignature=hmac_sha256_base64("$finalString", "$self->{_AWSSecret}");
  # For some reason we usually need an equals sign appended.  Check if required
  unless ($AWSSignature=~m/=$/) { $AWSSignature=$AWSSignature . "="; }
  $AWSSignature=URI::Escape::uri_escape( "$AWSSignature", "^A-Za-z0-9\-_.~" );
  return "$requestProtocol://" . $requestHost . $requestPath . "?" . join ('&', @b) . "&Signature=" . $AWSSignature;
}

sub SOAPSig {
  my ($self, $SOAPAction)=@_;
  $SOAPTimestamp=&getAWSTimeStamp();
  $finalString=$SOAPAction . $SOAPTimestamp;
  $AWSSignature=hmac_sha256_base64("$finalString", "$self->{_AWSSecret}");
  # For some reason we usually need an equals sign appended.  Check if required
  unless ($AWSSignature=~m/=$/) { $AWSSignature=$AWSSignature . "="; }
  @a=("$SOAPTimestamp", "$AWSSignature");
  return @a;
}


## Internal subs
sub getAWSTimeStamp {
	# The Timestamp must be generated in a specific format.
    return sprintf("%04d-%02d-%02dT%02d:%02d:%02d.000Z",
       sub {    ($_[5]+1900,
                 $_[4]+1,
                 $_[3],
                 $_[2],
                 $_[1],
                 $_[0])
           }->(gmtime(time)));
}

1;

__END__