File Coverage

blib/lib/Net/Amazon.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

###################################################################
package Net::Amazon;
######################################################################
# Mike Schilli , 2003
######################################################################

use 5.006;
use strict;
use warnings;

our $VERSION          = '0.62';
our $WSDL_DATE        = '2011-08-01';
our $Locale           = 'us';
our @CANNED_RESPONSES = ();
our $IS_CANNED        = 0;

use LWP::UserAgent;
use HTTP::Message;
use HTTP::Request::Common;
use XML::Simple;
use Data::Dumper;
use URI;
use Log::Log4perl qw(:easy get_logger);
use Time::HiRes qw(usleep gettimeofday tv_interval);
use Digest::SHA qw(hmac_sha256_base64);
use URI::Escape qw(uri_escape);

# Each key represents a search() type, and each value indicates which
# Net::Amazon::Request:: class to use to handle it.
use constant SEARCH_TYPE_CLASS_MAP => {
    actor        => 'Actor',
    artist       => 'Artist',
    all          => 'All',
    author       => 'Author',
    asin         => 'ASIN',
    blended      => 'Blended',
    browsenode   => 'BrowseNode',
    director     => 'Director',
    ean          => 'EAN',
    exchange     => 'Exchange',
    isbn         => 'ISBN',
    keyword      => 'Keyword',
    manufacturer => 'Manufacturer',
    musiclabel   => 'MusicLabel',
    power        => 'Power',
    publisher    => 'Publisher',
    seller       => 'Seller',
    similar      => 'Similar',
    textstream   => 'TextStream',
    title        => 'Title',
    upc          => 'UPC',
};

##################################################
sub new {
##################################################
    my($class, %options) = @_;

    if(! exists $options{token}) {
        die "Mandatory paramter 'token' not defined";
    }

    if(! exists $options{secret_key}) {
        die "Mandatory paramter 'secret_key' not defined";
    }

    if(! exists $options{associate_tag}) {
        die "Mandatory paramter 'associate_tag' not defined";
    }

    my $self = {
        strict         => 1,
        response_dump  => 0,
        rate_limit     => 1.0,  # 1 req/sec
        max_pages      => 5,
        ua             => LWP::UserAgent->new(),
        compress       => 1,
        %options,
    };

    # XXX: this has to be set as soon as possible to ensure
    # the validators pick up the correct locale.  I don't
    # like the way this works, and need to think of a better
    # solution.
    if (exists $self->{locale}) {
        $Net::Amazon::Locale = $self->{locale};
    }

    help_xml_simple_choose_a_parser();

    bless $self, $class;
}

##################################################
sub search {
##################################################
    my($self, %params) = @_;

    foreach my $key ( keys %params ) {
        next unless ( my $class = SEARCH_TYPE_CLASS_MAP->{$key} );

        return $self->_make_request($class, \%params);
    }

    # FIX?
    # This seems like it really should be a die() instead...this is
    # indicative of a programming problem. Generally speaking, it's
    # best to issue warnings from a module--you can't be sure that the
    # client has a stderr to begin with, or that he wants errors
    # spewed to it.
    warn "No Net::Amazon::Request type could be determined";

    return undef;
}

##################################################
sub intl_url {
##################################################
    my($self, $url) = @_;

    if(! exists $self->{locale}) {
        return $url;
    }

    if (0) {
    } elsif ($self->{locale} eq "ca") {
        $url =~ s/\.com/.ca/;
    } elsif ($self->{locale} eq "de") {
        $url =~ s/\.com/.de/;
    } elsif ($self->{locale} eq "es") {
        $url =~ s/\.com/.es/;
    } elsif ($self->{locale} eq "fr") {
        $url =~ s/\.com/.fr/;
    } elsif ($self->{locale} eq "jp") {
        $url =~ s/\.com/.co.jp/;
    } elsif ($self->{locale} eq "it") {
        $url =~ s/\.com/.it/;
    } elsif ($self->{locale} eq "uk") {
        $url =~ s/\.com/.co.uk/;
    }

    return $url;
}

##################################################
sub request {
##################################################
    my($self, $request) = @_;

    my $resp_class = $request->response_class();

    eval "require $resp_class;" or
        die "Cannot find '$resp_class'";

    my $res  = $resp_class->new();

    my $url  = URI->new($self->intl_url($request->amzn_xml_url()));
    my $page = (defined $request->page()) ?
	($request->page() - 1) * $self->{max_pages} + 1 :
	0;
    my $ref;
    my $max_pages_in_this_search = $self->{max_pages} + $page - 1;

    REQUEST: {
        my %params = $request->params(page => $page);
        $params{locale} = $self->{locale} if exists $self->{locale};

        $url->query_form(
            'Service'        => 'AWSECommerceService',
            'AWSAccessKeyId' => $self->{token},
            'Version'        => $WSDL_DATE,
            'AssociateTag'   => $self->{associate_tag},
            map { $_, $params{$_} } sort keys %params,
        );

        # Signed requests will have different URLs, which breaks caching.
        # Get a cachable URL before signing the request.
        my $url_cachablestr = $url->as_string;

        # New signature for >=2009-03-31. Do not alter URL after this!
        $url = $self->_sign_request($url) if exists $self->{secret_key};

        DEBUG(sub { "request: params = " . Dumper(\%params) . "\n"});

        my $urlstr = $url->as_string;

        DEBUG(sub { "urlstr=" . $urlstr });

        my $xml = fetch_url($self, $urlstr, $url_cachablestr, $res);

        if(!defined $xml) {
            return $res;
        }

        DEBUG(sub { "Received [ " . $xml . "]" });

        # Let the response class parse the XML
        $ref = $res->xml_parse($xml);

        # DEBUG(sub { Data::Dumper::Dumper($ref) });

        if(! defined $ref) {
            ERROR("Invalid XML");
            $res->messages( [ "Invalid XML" ]);
            $res->status("");
            return $res;
        }

        $res->current_page($ref, $page);
        $res->set_total_results($ref);

        my $rc = $res->is_page_error($ref);
        if ($rc == 0) {
            return $res;
        } elsif ($rc == -1) {
            last;
        }

        my $new_items = $res->xmlref_add($ref);

        DEBUG("Received valid XML ($new_items items)");

        # Stop if we've fetched max_pages already
        if(defined $page && $max_pages_in_this_search <= $page) {
            DEBUG("Fetched max_pages ($max_pages_in_this_search) -- stopping");
            last;
        }

        if($res->is_page_available($ref, $new_items, $page)) {
            $page++;
            redo REQUEST;
        }

        # We're gonna fall out of this loop here.
    }

    $res->status(1);
    # We have a valid response, so if TotalResults isn't set,
    # we most likely have a single response
    $res->total_results(1) unless defined $res->total_results();
    return $res;
}

##################################################
sub fetch_url {
##################################################
    my($self, $url, $url_cachablestr, $res) = @_;

    my $max_retries = 2;

    INFO("Fetching $url");

    if(@CANNED_RESPONSES) {
        $IS_CANNED = 1;
        INFO("Serving canned response (testing)");
        return shift @CANNED_RESPONSES;
    }

    if(exists $self->{cache}) {
        my $resp = $self->{cache}->get($url_cachablestr);
        if(defined $resp) {
            INFO("Serving from cache");
            return $resp;
        }

        INFO("Cache miss");
    }

    my $ua = $self->{ua};
    $ua->env_proxy();

    my $resp;

    {
        # wait up to a second before the next request so
        # as to not violate Amazon's 1 query per second
        # rule (or the configured rate_limit).
        $self->pause() if $self->{strict};

        {
            my $req = GET $url;

            $req->header("Accept-Encoding" => [ HTTP::Message::decodable() ])
                if $self->{compress};

            $resp = $ua->request($req);
        }

        $self->reset_timer() if $self->{strict};

        if($resp->is_error) {
            # retry on 503 Service Unavailable errors
            if ($resp->code == 503) {
                if ($max_retries-- >= 0) {
                    INFO("Temporary Amazon error 503, retrying");
                    redo;
                } else {
                    INFO("Out of retries, giving up");
                    $res->status("");
                    $res->messages( [ "Too many temporary Amazon errors" ] );
                    return undef;
                }
            } else {
                $res->status("");
                $res->messages( [ $resp->message ] );
                return undef;
            }
        }

        if($self->{response_dump}) {
            my $dumpfile = "response-$self->{response_dump}.txt";
            open FILE, ">$dumpfile" or die "Cannot open $dumpfile";
            print FILE $resp->decoded_content();
            close FILE;
            $self->{response_dump}++;
        }

        if($resp->decoded_content =~ // &&
            # Is this the same value of AWS4?
           $resp->decoded_content =~ /Please retry/i) {
            if($max_retries-- >= 0) {
                INFO("Temporary Amazon error, retrying");
                redo;
            } else {
                INFO("Out of retries, giving up");
                $res->status("");
                $res->messages( [ "Too many temporary Amazon errors" ] );
                return undef;
            }
        }
    }

    if(exists $self->{cache}) {
        $self->{cache}->set($url_cachablestr, $resp->decoded_content());
    }

    return $resp->decoded_content();
}

##################################################
# Poor man's Class::Struct
##################################################
sub make_accessor {
##################################################
    my($package, $name) = @_;

    no strict qw(refs);

    my $code = <
        *{"$package\\::$name"} = sub {
            my(\$self, \$value) = \@_;

            if(defined \$value) {
                \$self->{$name} = \$value;
            }
            if(exists \$self->{$name}) {
                return (\$self->{$name});
            } else {
                return "";
            }
        }
EOT
    if(! defined *{"$package\::$name"}) {
        eval $code or die "$@";
    }
}

# An accessor for backward compatability with AWS3.
##################################################
sub make_compatible_accessor{
##################################################
    my($package, $old_name, $new_name) = @_;

    no strict qw(refs);

    my $code = <
        *{"$package\\::$old_name"} = sub {
            my(\$self, \$value) = \@_;

            if(defined \$value) {
                \$self->{$new_name} = \$value;
            }
            if(exists \$self->{$new_name}) {
                return (\$self->{$new_name});
            } else {
                return "";
            }
        }
EOT
    if(! defined *{"$package\::$old_name"}) {
        eval $code or die "$@";
    }
}

##################################################
# Make accessors for arrays
##################################################
sub make_array_accessor {
##################################################
    my($package, $name) = @_;

    no strict qw(refs);

    my $code = <
        *{"$package\\::$name"} = sub {
            my(\$self, \$nameref) = \@_;
            if(defined \$nameref) {
                if(ref \$nameref eq "ARRAY") {
                    \$self->{$name} = \$nameref;
                } else {
                    \$self->{$name} = [\$nameref];
                }
            }
               # Return a list
            if(exists \$self->{$name} and
               ref \$self->{$name} eq "ARRAY") {
                return \@{\$self->{$name}};
            }

            return undef;
        }
EOT

    if(! defined *{"$package\::$name"}) {
        eval $code or die "$@";
    }
}

##################################################
sub walk_hash_ref {
##################################################
    my ($package, $href, $aref) = @_;

    return $href if scalar(@$aref) == 0;

    my @a;
    push @a, $_ for @$aref;

    my $tail = pop @a;
    my $ref = $href;

    for my $part (@a) {
        $ref = $ref->{$part};
    }

    return $ref->{$tail};
}


##################################################
sub artist {
##################################################
    my($self, $nameref) = @_;

    # Only return the first artist
    return ($self->artists($nameref))[0];
}

##################################################
sub version {
##################################################
    my($self) = @_;
    return $self->{Version};
}

##################################################
sub current_page {
##################################################
    my($self, $ref, $page) = @_;
    if(exists $ref->{Items}->{TotalPages}) {
        INFO("Page $page/$ref->{Items}->{TotalPages}");
    }
}

##################################################
sub set_total_results {
##################################################
    my($self, $ref) = @_;
    if(exists $ref->{Items}->{TotalResults}) {
        $self->total_results( $ref->{Items}->{TotalResults} );
    }
}

##################################################
sub is_page_error {
##################################################
    my($self, $ref) = @_;

    if(exists $ref->{Items}->{Request}->{Errors}) {
        my $errref = $ref->{Items}->{Request}->{Errors};

        if (ref($errref->{Error}) eq "ARRAY") {
            my @errors;
            for my $e (@{$errref->{Error}}) {
                push @errors, $e->{Message};
            }
            # multiple errors, set arrary ref
            $self->messages( \@errors );
        } else {
            # single error, create array
            $self->messages( [ $errref->{Error}->{Message} ] );
        }

        ERROR("Fetch Error: " . $self->message );
        $self->status("");
        return 0;
    }
    return 1;
}

##################################################
sub is_page_available {
##################################################
    my($self, $ref, $new_items, $page) = @_;
    if(exists $ref->{Items}->{TotalPages} and
              $ref->{Items}->{TotalPages} > $page and
              $IS_CANNED ne 1) {
        DEBUG("Page $page of $ref->{Items}->{TotalPages} fetched - continuing");
        return 1;
    }
    return 0;
}

##################################################
sub xmlref_add {
##################################################
    my($self, $xmlref) = @_;

    my $nof_items_added = 0;
    return $nof_items_added unless defined $xmlref;

    # Push a nested hash structure, retrieved via XMLSimple, onto the
    # object's internal 'xmlref' entry, which holds a ref to an array,
    # whichs elements are refs to hashes holding an item's attributes
    # (like OurPrice etc.)

    #DEBUG("xmlref_add ", Data::Dumper::Dumper($xmlref));

    unless(ref($self->{xmlref}) eq "HASH" &&
           ref($self->{xmlref}->{Items}) eq "ARRAY") {
        $self->{xmlref}->{Items} = [];
    }

    if(ref($xmlref->{Items}->{Item}) eq "ARRAY") {
        push @{$self->{xmlref}->{Items}}, @{$xmlref->{Items}->{Item}};
        $nof_items_added = scalar @{$xmlref->{Items}->{Item}};
    } else {
        if (exists $xmlref->{Items}->{Item}->{ItemAttributes}) {
            push @{$self->{xmlref}->{Items}}, $xmlref->{Items}->{Item};
            $nof_items_added = 1;
        }
    }

    DEBUG("xmlref_add (after):", Data::Dumper::Dumper($self));
    return $nof_items_added;
}

##################################################
sub help_xml_simple_choose_a_parser {
##################################################

    eval "require XML::Parser";
    unless($@) {
        $XML::Simple::PREFERRED_PARSER = "XML::Parser";
        return;
    }

    eval "require XML::SAX::PurePerl";
    unless($@) {
        $XML::Simple::PREFERRED_PARSER = "XML::SAX::PurePerl";
        return;
    }
}

##################################################
# This timer makes sure we don't query Amazon more
# than once a second.
##################################################
sub reset_timer {
##################################################

    my $self = shift;
    $self->{t0} = [gettimeofday];
}

##################################################
# Pause for up to a second if necessary.
##################################################
sub pause {
##################################################

    my $self = shift;
    return unless ($self->{t0});

    my $t1 = [gettimeofday];
    my $dur = (1.0/$self->{rate_limit} -
               tv_interval($self->{t0}, $t1)) * 1000000;
    if($dur > 0) {
            # Use a pseudo subclass for the logger, since the app
            # might not want to log that as 'ERROR'. Log4perl's
            # inheritance mechanism makes sure it does the right
            # thing for the current class.
        my $logger = get_logger(__PACKAGE__ . "::RateLimit");
        $logger->error("Ratelimiting: Sleeping $dur microseconds");
        usleep($dur);
    }
}

##
## 'PRIVATE' METHODS
##

# $self->_make_request( TYPE, PARAMS )
#
# Takes a TYPE that corresponds to a Net::Amazon::Request
# class, require()s that class, instantiates it, and returns
# the result of that instance's request() method.
#
sub _make_request {
    my ($self, $type, $params) = @_;

    my $class = "Net::Amazon::Request::$type";

	# XXX: change me back, this makes debugging a little difficult.
    eval "require $class";

    my $req = $class->new(%{$params});

    return $self->request($req);
}

# $self->_sign_request( URI )
#
# Takes a URI object that corresponds to a Net::Amazon::Request
# adds the required Timestamp and Signature parameters, and returns it
# See http://docs.amazonwebservices.com/AWSECommerceService/2009-03-31/DG/Query_QueryAuth.html
sub _sign_request {
    my ($self,$uri) = @_;
    return $uri unless exists $self->{secret_key};
    # This assumes no duplicated keys. Safe assumption?
    my %query = $uri->query_form;
    my @now = gmtime;
    $query{Timestamp} ||= sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',$now[5]+1900,$now[4]+1,@now[3,2,1,0]);
    my $qstring = join '&', map {"$_=". uri_escape($query{$_},"^A-Za-z0-9\-_.~")} sort keys %query;
    # Use chr(10), not "\n" which varies by platform
    my $signme = join chr(10),"GET",$uri->host,$uri->path,$qstring;
    my $sig = hmac_sha256_base64($signme, $self->{secret_key});
    # Digest does not properly pad b64 strings
    $sig .= '=' while length($sig) % 4;
    $sig = uri_escape($sig,"^A-Za-z0-9\-_.~");
    $qstring .= "&Signature=$sig";
    $uri->query( $qstring );
    return $uri;
}

1;

__END__