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

Diff of /FigKernelPackages/ACHserver.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3, Mon May 18 17:00:00 2009 UTC revision 1.11, Wed Nov 25 21:22:22 2009 UTC
# Line 1  Line 1 
1    
2  package ACHserver;  package ACHserver;
3    
4    #
5    # This is a SAS Component
6    #
7        use strict;
8  use LWP::UserAgent;  use LWP::UserAgent;
 use Data::Dumper;  
9  use YAML;  use YAML;
10        use ErrorMessage;
11        no warnings qw(once);
12    
13  use strict;  =head1 Annotation Clearinghouse Server Helper Object
14    
15  sub new  =head2 Description
16  {  
17      my($class, $server_url) = @_;  This module is used to call the Annotation Clearinghouse Server, which is a
18    special-purpose server for assertion data from the Sapling database. Each
19    Annotation Clearinghouse Server function corresponds to a method of this object.
20    
21    This package deliberately uses no internal SEED packages or scripts, only common
22    PERL modules.
23    
24    The fields in this object are as follows.
25    
26    =over 4
27    
28    =item server_url
29    
30    The URL used to request data from the subsystem server.
31    
32    =item ua
33    
34    The user agent for communication with the server.
35    
36    =item singleton
37    
38    Indicates whether or not results are to be returned in singleton mode. In
39    singleton mode, if the return document is a hash reference with only one
40    entry, the entry value is returned rather than the hash.
41    
42    =back
43    
44    =cut
45    
46    =head3 new
47    
48        my $ss = ACHserver->new(%options);
49    
50    Construct a new server object. The
51    following options are supported.
52    
53      $server_url = "http://servers.nmpdr.org/ach/server.cgi" unless $server_url;  =over 4
54    
55      #$server_url = "http://bio-macpro-2.mcs.anl.gov/~disz/FIG/ach_server.cgi" unless $server_url;  =item url
     #$server_url = "http://bio-macpro-1.mcs.anl.gov/ross-proj/FIG/co_occurs_server.cgi" unless $server_url;  
56    
57      my $self = {  URL for the server. This option is required.
58    
59    =item singleton (optional)
60    
61    If TRUE, results from methods will be returned in singleton mode. In singleton
62    mode, if a single result comes back, it will come back as a scalar rather than
63    as a hash value accessible via an incoming ID.
64    
65    =back
66    
67    =cut
68    
69    sub new {
70        # Get the parameters.
71        my ($class, %options) = @_;
72        # Turn off YAML compression, which causes problems with our hash keys.
73        $YAML::CompressSeries = 0;
74        # Get the options.
75        my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";
76        my $singleton = $options{singleton} || 0;
77        # Create the fields of the object. Note that if we're in localhost mode,
78        # the user agent is actually a SAP object.
79        my $server_url = $url;
80        my $ua;
81        if ($server_url ne 'localhost') {
82            require LWP::UserAgent;
83            $ua = LWP::UserAgent->new();
84            $ua->timeout(20 * 60);
85        } else {
86            require "ACH.pm";
87            $ua = ACH->new();
88        }
89        # Create the server object.
90        my $retVal = {
91          server_url => $server_url,          server_url => $server_url,
92          ua => LWP::UserAgent->new(),                      ua => $ua,
93                        singleton => $singleton,
94      };      };
95      return bless $self, $class;      # Bless it.
96        bless $retVal, $class;
97        # Get the list of permitted methods from the server.
98        my $methodList = $retVal->_call_method(methods => []);
99        # Convert it to a hash and store it in this object.
100        $retVal->{methodHash} = { map { $_ => 1 } @$methodList };
101        # Return the object.
102        return $retVal;
103  }  }
104    
105  sub equiv_precise {  =head3 AUTOLOAD
106          my ($self, @args) = @_;  
107          return $self->run_query("equiv_precise", @args);      my $result = $server->method(%args);
108    
109    Call a function on the server. Any method call on this object (other than
110    the constructor) is translated into a request against the server. This
111    enables us to add new server functions without requiring an update to this
112    object or its parent. The parameters are usually specified as a hash, and the
113    result is a scalar or object reference. In some cases the parameters are a list.
114    To deistinguish between the two cases, all hash keys must begin with hyphens.
115    
116    If an error occurs, we will throw an exception.
117    
118    =cut
119    
120    # This variable will contain the method name.
121    our $AUTOLOAD;
122    
123    sub AUTOLOAD {
124        # Get the parameters. We do some fancy dancing to allow the user to pass
125        # in a hash, a list, a list reference, or a hash reference.
126        my $self = shift @_;
127        my $args = $_[0];
128        if (defined $args) {
129            if (scalar @_ gt 1) {
130                # Here we have multiple arguments. We check the first one for a
131                # leading hyphen.
132                if ($args =~ /^-/) {
133                    # This means we have hash-form parameters.
134                    my %args = @_;
135                    $args = \%args;
136                } else {
137                    # This means we have list-form parameters.
138                    my @args = @_;
139                    $args = \@args;
140                }
141            } else {
142                # Here we have a single argument. If it's a scalar, we convert it
143                # to a singleton list.
144                if (! ref $args) {
145                    $args = [$args];
146  }  }
147  sub equiv_sequence {          }
148          my ($self, @args) = @_;      }
149          return $self->run_query("equiv_sequence", @args);      # Declare the return variable.
150        my $retVal;
151        # Get the method name.
152        my $function = $AUTOLOAD;
153        # Strip off the stuff before the method name.
154        $function =~ s/.+:://;
155        # Validate the method name.
156        if (! $self->{methodHash}{$function}) {
157            die "Method \"$function\" not supported.";
158        } else {
159            # Call the method.
160            $retVal = $self->_call_method($function, $args);
161            # We have our result. Adjust for singleton mode.
162            if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
163                # Here we're in singleton mode and we got a single result,
164                # so we dereference a bit to make it easier for the user
165                # to access it.
166                ($retVal) = values %$retVal;
167            }
168        }
169        # Return the result.
170        return $retVal;
171  }  }
172    
173    =head3 DESTROY
174    
175  sub run_query      $ss->DESTROY();
176  {  
177      my($self, $function, @args ) = @_;  This method has no function. It's purpose is to keep the destructor from
178    being caught by the autoload processing.
179    
180    =cut
181    
182    sub DESTROY { }
183    
184              my $arg_string = Dump(@args);  =head2 Utility Methods
             my $form = [function => $function,  
                         args => "$arg_string"];  
185    
186              my $res = $self->{ua}->post($self->{server_url}, $form);  =head3 _call_method
187              if ($res->is_success)  
188        my $result = $server->_call_method($method, $args);
189    
190    Call the specified method on the server with the specified arguments and
191    return the result. The arguments must already be packaged as a hash or
192    list reference. This method is the heart of the AUTOLOAD method, and is
193    provided as a utility for specialized methods that can't use the AUTOLOAD
194    facility.
195    
196    =over 4
197    
198    =item method
199    
200    Name of the server function being invoked.
201    
202    =item args
203    
204    Argument object to pass to the function.
205    
206    =item RETURN
207    
208    Returns a hash or list reference with the function results.
209    
210    =back
211    
212    =cut
213    
214    sub _call_method {
215        # Get the parameters.
216        my ($self, $method, $args) = @_;
217        # Declare the return variable.
218        my $retVal;
219        # Get our user agent.
220        my $ua = $self->{ua};
221        # Determine the type.
222        if (ref $ua eq 'LWP::UserAgent') {
223            # Here we're going to a server. Compute the argument document.
224            my $argString = YAML::Dump($args);
225            # Request the function from the server.
226            my $content = $self->_send_request(function => $method, args => $argString,
227                                               source => __PACKAGE__);
228            $retVal = YAML::Load($content);
229        } else {
230            # Here we're calling a local method.
231            $retVal = eval("\$ua->$method(\$args)");
232            # Check for an error.
233            if ($@) {
234                die "Package error: $@";
235            }
236        }
237        # Return the result.
238        return $retVal;
239    }
240    
241    =head3 _send_request
242    
243        my $result = $server->_send_request(%parms);
244    
245    Send a request to the server. This method must not be called in localhost
246    mode. If an error occurs, this method will die; otherwise, the content of
247    the response will be passed back as the result.
248    
249    =over 4
250    
251    =item parms
252    
253    Hash of CGI parameters to send to the server.
254    
255    =item RETURN
256    
257    Returns the string returned by the server in response to the request.
258    
259    =back
260    
261    =cut
262    
263    sub _send_request {
264        # Get the parameters.
265        my ($self, %parms) = @_;
266        # Get the user agent.
267        my $ua = $self->{ua};
268        # Request the function from the server. Note that the hash is actually passed
269        # as a list reference.
270    
271        #
272        # retries is the set of retry wait times in seconds we should use. when
273        # we run out the call will fail.
274        #
275    
276        my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
277        my %codes_to_retry =  map { $_ => 1 } qw(110 408 502 503 504 200) ;
278        my $response;
279        while (1)
280              {              {
281                  my $rc;          $response = $ua->post($self->{server_url}, [ %parms ]);
282                  eval {          if ($response->is_success)
                     $rc = Load($res->content);  
                 };  
                 if ($@)  
283                  {                  {
284                      die "Bad YAML parse $@ on input\n" .  $res->content;              my $retVal = $response->content;
285                return $retVal;
286                  }                  }
287              }  
288              else          #
289            # If this is not one of the error codes we retry for, or if we
290            # are out of retries, fail immediately
291            #
292            my $code = $response->code;
293            if (!$codes_to_retry{$code} || @retries == 0)
294              {              {
295                  die "error on post " . $res->status_line . " " . $res->content;              if ($ENV{SAS_DEBUG}) {
296                    confess $response->content;
297                } else {
298                    confess $response->status_line;
299              }              }
300  }  }
301    
302            #
303            # otherwise, sleep & loop.
304            #
305            my $retry_time = shift(@retries);
306            print STDERR "Request failed with code=$code, sleeping $retry_time and retrying\n";
307            sleep($retry_time);
308    
309  1;      }
310    
311        #
312        # Should never get here.
313        #
314    }
315    
316    
317    1;

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.11

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3