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

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.12

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3