[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.5, Tue Jun 30 19:02:29 2009 UTC revision 1.11, Wed Nov 25 21:22:22 2009 UTC
# Line 4  Line 4 
4  #  #
5  # This is a SAS Component  # 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  #  =head2 Description
 # This is a SAS Component  
 #  
16    
17    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  sub new  This package deliberately uses no internal SEED packages or scripts, only common
22  {  PERL modules.
23      my($class, $server_url) = @_;  
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  }  }
148  sub equiv_sequence {      }
149          my ($self, @args) = @_;      # Declare the return variable.
150          return $self->run_query("equiv_sequence", @args);      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();
 {  
     my($self, $function, @args ) = @_;  
176    
177              my $arg_string = Dump(@args);  This method has no function. It's purpose is to keep the destructor from
178              my $form = [function => $function,  being caught by the autoload processing.
                         args => "$arg_string"];  
179    
180              my $res = $self->{ua}->post($self->{server_url}, $form);  =cut
181              if ($res->is_success)  
182              {  sub DESTROY { }
183                  return Load($res->content);  
184    =head2 Utility Methods
185    
186    =head3 _call_method
187    
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              }              }
             else  
             {  
                 die "error on post " . $res->content;  
236              }              }
237        # Return the result.
238        return $retVal;
239  }  }
240    
241  sub run_query_bad  =head3 _send_request
242  {  
243      my($self, $function, @args ) = @_;      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              my $arg_string = Dump(@args);  Returns the string returned by the server in response to the request.
             my $form = [function => $function,  
                         args => "$arg_string"];  
258    
259              my $res = $self->{ua}->post($self->{server_url}, $form);  =back
260              if ($res->is_success)  
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  print Dumper $res;          $response = $ua->post($self->{server_url}, [ %parms ]);
282                  my $rc;          if ($response->is_success)
                 eval {  
                     $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              else  
288            #
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.5  
changed lines
  Added in v.1.11

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3