Base.pm

package Amazon::SQS::Simple::Base;

use strict;
use warnings;
use Carp qw( croak carp );
use Digest::HMAC_SHA1;
use LWP::UserAgent;
use MIME::Base64;
use URI::Escape;
use XML::Simple;

use base qw(Exporter);

use constant SQS_VERSION_2009_02_01 => '2009-02-01';
use constant SQS_VERSION_2008_01_01 => '2008-01-01';
use constant BASE_ENDPOINT          => 'http://queue.amazonaws.com';
use constant MAX_GET_MSG_SIZE       => 4096; # Messages larger than this size will be sent
                                             # using a POST request.
                                       
our $DEFAULT_SQS_VERSION = +SQS_VERSION_2009_02_01;
our @EXPORT = qw(SQS_VERSION_2009_02_01 SQS_VERSION_2008_01_01);

sub new {
    my $class = shift;
    my $access_key = shift;
    my $secret_key = shift;
    
    my $self = {
        AWSAccessKeyId   => $access_key,
        SecretKey        => $secret_key,
        Endpoint         => +BASE_ENDPOINT,
        SignatureVersion => 1,
        Version          => $DEFAULT_SQS_VERSION,
        @_,
    };

    if (!$self->{AWSAccessKeyId} || !$self->{SecretKey}) {
        croak "Missing AWSAccessKey or SecretKey";
    }

    # validate the Version, warn if it's not one we recognise
    my @valid_versions = ( +SQS_VERSION_2008_01_01, +SQS_VERSION_2009_02_01 );
    if (!grep {$self->{Version} eq $_} @valid_versions) {
        carp "Warning: " 
           . $self->{Version} 
           . " might not be a valid version. Recognised versions are " 
           . join(', ', @valid_versions);
    }

    $self = bless($self, $class);
    $self->_debug_log("Version is set to $self->{Version}");
    return $self;
}

sub _api_version {
    my $self = shift;
    return $self->{Version};
}

sub _dispatch {
    my $self         = shift;
    my $params       = shift || {};
    my $force_array  = shift || [];
    my $post_request = 0;
    my $ua           = LWP::UserAgent->new();
    my $url          = $self->{Endpoint};
    my $response;
    my $post_body;
    
    if ($self->{Timeout}) {
        $ua->timeout($self->{Timeout});
    }

    $ua->env_proxy;
    
    $params = {
        AWSAccessKeyId      => $self->{AWSAccessKeyId},
        Version             => $self->{Version},
        %$params
    };

    if (!$params->{Timestamp} && !$params->{Expires}) {
        $params->{Timestamp} = _timestamp();
    }
    
    if ($params->{MessageBody} && length($params->{MessageBody}) > +MAX_GET_MSG_SIZE) {
        $post_request = 1;
    }

    my $query = $self->_get_signed_query($params);

    $self->_debug_log($query);

    if ($post_request) {
        $response = $ua->post(
            $url, 
            'Content-type' => 'application/x-www-form-urlencoded', 
            'Content'      => $query
        );
    }
    else {
        $response = $ua->get("$url/?$query");
    }
        
    if ($response->is_success) {
        $self->_debug_log($response->content);
        my $href = XMLin($response->content, ForceArray => $force_array, KeyAttr => {});
        return $href;
    }
    else {
        my $msg;
        eval {
            my $href = XMLin($response->content);
            $msg = $href->{Error}{Message};
        };
        
        my $error = "ERROR: On calling $params->{Action}: " . $response->status_line;
        $error .= " ($msg)" if $msg;
        croak $error;
    }
}

sub _debug_log {
    my ($self, $msg) = @_;
    return unless $self->{_Debug};
    chomp($msg);
    print {$self->{_Debug}} $msg . "\n\n";
}

sub _get_signed_query {
    my ($self, $params) = @_;
    my $sig = '';
    
    if ($self->{SignatureVersion} == 1) {
        $params->{SignatureVersion} = $self->{SignatureVersion};
    
        for my $key( sort { uc $a cmp uc $b } keys %$params ) {
            if (defined $params->{$key}) {
                $sig = $sig . $key . $params->{$key};
            }
        }
    } else {
        $sig = $params->{Action} . $params->{Timestamp};
    }

    my $hmac = Digest::HMAC_SHA1->new($self->{SecretKey})->add($sig);
    
    # Need to escape + characters in signature
    # see http://docs.amazonwebservices.com/AWSSimpleQueueService/2006-04-01/Query_QueryAuth.html
    $params->{Signature}     = uri_escape(encode_base64($hmac->digest, ''));
    $params->{MessageBody}   = uri_escape($params->{MessageBody}) if $params->{MessageBody};
    
    # Likewise, need to escape + characters in ReceiptHandle
    $params->{ReceiptHandle} = uri_escape($params->{ReceiptHandle}) if $params->{ReceiptHandle};
    
    my $query = join('&', map { $_ . '=' . $params->{$_} } keys %$params);
    return $query;
}

sub _timestamp {
    my $t = shift;
    if (!defined $t) {
        $t = time;
    }
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($t);
    return sprintf("%4i-%02i-%02iT%02i:%02i:%02iZ",
        ($year + 1900),
        ($mon + 1),
        $mday,
        $hour,
        $min,
        $sec
    );
}

1;

__END__

=head1 NAME

Amazon::SQS::Simple::Base - No user-serviceable parts included

=head1 AUTHOR

Copyright 2007-2008 Simon Whitaker E<lt>swhitaker@cpan.orgE<gt>

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut