Parent Directory
| 
Revision Log
Add retry logic
package ACHserver;
#
# This is a SAS Component
#
use strict;
use LWP::UserAgent;
use YAML;
use ErrorMessage;
no warnings qw(once);
=head1 Annotation Clearinghouse Server Helper Object
=head2 Description
This module is used to call the Annotation Clearinghouse Server, which is a
special-purpose server for assertion data from the Sapling database. Each
Annotation Clearinghouse Server function corresponds to a method of this object.
This package deliberately uses no internal SEED packages or scripts, only common
PERL modules.
The fields in this object are as follows.
=over 4
=item server_url
The URL used to request data from the subsystem server.
=item ua
The user agent for communication with the server.
=item singleton
Indicates whether or not results are to be returned in singleton mode. In
singleton mode, if the return document is a hash reference with only one
entry, the entry value is returned rather than the hash.
=back
=cut
=head3 new
my $ss = ACHserver->new(%options);
Construct a new server object. The
following options are supported.
=over 4
=item url
URL for the server. This option is required.
=item singleton (optional)
If TRUE, results from methods will be returned in singleton mode. In singleton
mode, if a single result comes back, it will come back as a scalar rather than
as a hash value accessible via an incoming ID.
=back
=cut
sub new {
# Get the parameters.
my ($class, %options) = @_;
# Turn off YAML compression, which causes problems with our hash keys.
$YAML::CompressSeries = 0;
# Get the options.
my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";
my $singleton = $options{singleton} || 0;
# Create the fields of the object. Note that if we're in localhost mode,
# the user agent is actually a SAP object.
my $server_url = $url;
my $ua;
if ($server_url ne 'localhost') {
require LWP::UserAgent;
$ua = LWP::UserAgent->new();
$ua->timeout(20 * 60);
} else {
require "ACH.pm";
$ua = ACH->new();
}
# Create the server object.
my $retVal = {
server_url => $server_url,
ua => $ua,
singleton => $singleton,
};
# Bless it.
bless $retVal, $class;
# Get the list of permitted methods from the server.
my $methodList = $retVal->_call_method(methods => []);
# Convert it to a hash and store it in this object.
$retVal->{methodHash} = { map { $_ => 1 } @$methodList };
# Return the object.
return $retVal;
}
=head3 AUTOLOAD
my $result = $server->method(%args);
Call a function on the server. Any method call on this object (other than
the constructor) is translated into a request against the server. This
enables us to add new server functions without requiring an update to this
object or its parent. The parameters are usually specified as a hash, and the
result is a scalar or object reference. In some cases the parameters are a list.
To deistinguish between the two cases, all hash keys must begin with hyphens.
If an error occurs, we will throw an exception.
=cut
# This variable will contain the method name.
our $AUTOLOAD;
sub AUTOLOAD {
# Get the parameters. We do some fancy dancing to allow the user to pass
# in a hash, a list, a list reference, or a hash reference.
my $self = shift @_;
my $args = $_[0];
if (defined $args) {
if (scalar @_ gt 1) {
# Here we have multiple arguments. We check the first one for a
# leading hyphen.
if ($args =~ /^-/) {
# This means we have hash-form parameters.
my %args = @_;
$args = \%args;
} else {
# This means we have list-form parameters.
my @args = @_;
$args = \@args;
}
} else {
# Here we have a single argument. If it's a scalar, we convert it
# to a singleton list.
if (! ref $args) {
$args = [$args];
}
}
}
# Declare the return variable.
my $retVal;
# Get the method name.
my $function = $AUTOLOAD;
# Strip off the stuff before the method name.
$function =~ s/.+:://;
# Validate the method name.
if (! $self->{methodHash}{$function}) {
die "Method \"$function\" not supported.";
} else {
# Call the method.
$retVal = $self->_call_method($function, $args);
# We have our result. Adjust for singleton mode.
if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
# Here we're in singleton mode and we got a single result,
# so we dereference a bit to make it easier for the user
# to access it.
($retVal) = values %$retVal;
}
}
# Return the result.
return $retVal;
}
=head3 DESTROY
$ss->DESTROY();
This method has no function. It's purpose is to keep the destructor from
being caught by the autoload processing.
=cut
sub DESTROY { }
=head2 Utility Methods
=head3 _call_method
my $result = $server->_call_method($method, $args);
Call the specified method on the server with the specified arguments and
return the result. The arguments must already be packaged as a hash or
list reference. This method is the heart of the AUTOLOAD method, and is
provided as a utility for specialized methods that can't use the AUTOLOAD
facility.
=over 4
=item method
Name of the server function being invoked.
=item args
Argument object to pass to the function.
=item RETURN
Returns a hash or list reference with the function results.
=back
=cut
sub _call_method {
# Get the parameters.
my ($self, $method, $args) = @_;
# Declare the return variable.
my $retVal;
# Get our user agent.
my $ua = $self->{ua};
# Determine the type.
if (ref $ua eq 'LWP::UserAgent') {
# Here we're going to a server. Compute the argument document.
my $argString = YAML::Dump($args);
# Request the function from the server.
my $content = $self->_send_request(function => $method, args => $argString,
source => __PACKAGE__);
$retVal = YAML::Load($content);
} else {
# Here we're calling a local method.
$retVal = eval("\$ua->$method(\$args)");
# Check for an error.
if ($@) {
die "Package error: $@";
}
}
# Return the result.
return $retVal;
}
=head3 _send_request
my $result = $server->_send_request(%parms);
Send a request to the server. This method must not be called in localhost
mode. If an error occurs, this method will die; otherwise, the content of
the response will be passed back as the result.
=over 4
=item parms
Hash of CGI parameters to send to the server.
=item RETURN
Returns the string returned by the server in response to the request.
=back
=cut
sub _send_request {
# Get the parameters.
my ($self, %parms) = @_;
# Get the user agent.
my $ua = $self->{ua};
# Request the function from the server. Note that the hash is actually passed
# as a list reference.
#
# retries is the set of retry wait times in seconds we should use. when
# we run out the call will fail.
#
my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
my %codes_to_retry = map { $_ => 1 } qw(110 408 502 503 504 200) ;
while (1)
{
my $response = $ua->post($self->{server_url}, [ %parms ]);
if ($response->is_success)
{
my $retVal = $response->content;
return $retVal;
}
#
# If this is not one of the error codes we retry for, or if we
# are out of retries, fail immediately
#
my $code = $response->code;
if (!$codes_to_retry{$code} || @retries == 0)
{
die ErrorMessage->new($response->content, $response->status_line);
}
#
# otherwise, sleep & loop.
#
my $retry_time = shift(@retries);
print STDERR "Request failed with code=$code, sleeping $retry_time and retrying\n";
sleep($retry_time);
}
#
# Should never get here.
#
}
1;
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |