[Bio] / FigKernelPackages / ACHserver.pm Repository:
ViewVC logotype

View of /FigKernelPackages/ACHserver.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.10 - (download) (as text) (annotate)
Wed Nov 25 20:09:40 2009 UTC (10 years, 4 months ago) by olson
Branch: MAIN
Changes since 1.9: +40 -8 lines
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.



=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.



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;


    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.


# This variable will contain the method name.

    # 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


This method has no function. It's purpose is to keep the destructor from
being caught by the autoload processing.


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

=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.



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.



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";


    # Should never get here.


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3