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

Annotation of /FigKernelPackages/ClientThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (view) (download) (as text)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :     #
3 :     # This is a SAS Component.
4 :     #
5 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
6 :     # for Interpretations of Genomes. All Rights Reserved.
7 :     #
8 :     # This file is part of the SEED Toolkit.
9 :     #
10 :     # The SEED Toolkit is free software. You can redistribute
11 :     # it and/or modify it under the terms of the SEED Toolkit
12 :     # Public License.
13 :     #
14 :     # You should have received a copy of the SEED Toolkit Public License
15 :     # along with this program; if not write to the University of Chicago
16 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
17 :     # Genomes at veronika@thefig.info or download a copy from
18 :     # http://www.theseed.org/LICENSE.TXT.
19 :     #
20 :    
21 :     package ClientThing;
22 :    
23 :     use strict;
24 : parrello 1.30 use YAML::XS;
25 : parrello 1.2 use ErrorMessage;
26 : parrello 1.6 use Carp;
27 : parrello 1.1 no warnings qw(once);
28 : olson 1.10 use POSIX;
29 : olson 1.20 use HTTP::Message;
30 : parrello 1.1
31 : olson 1.17 use constant AGENT_NAME => "SAS client";
32 :    
33 : parrello 1.1 =head1 Base Class for Server Helper Objects
34 :    
35 :     =head2 Description
36 :    
37 :     This object is used as the base class for the various server objects. It provides
38 :     the functions needed to invoke one of the servers.
39 :    
40 :     This package deliberately uses no internal SEED packages or scripts, only common
41 :     PERL modules.
42 :    
43 :     The fields in this object are as follows.
44 :    
45 :     =over 4
46 :    
47 :     =item server_url
48 :    
49 :     The URL used to request data from the sapling server. If C<localhost> is
50 :     specified, then the L<SAP> module will be called directly.
51 :    
52 :     =item ua
53 :    
54 :     The user agent for communication with the server.
55 :    
56 :     =item singleton
57 :    
58 :     Indicates whether or not results are to be returned in singleton mode. In
59 :     singleton mode, if the return document is a hash reference with only one
60 :     entry, the entry value is returned rather than the hash.
61 :    
62 : parrello 1.2 =item methodHash
63 :    
64 :     Reference to a hash keyed by the names of the server's permissible methods.
65 :    
66 : parrello 1.1 =back
67 :    
68 :     =head2 Creating a Server Client Package
69 :    
70 :     The code to create a server client package is simple. The following program
71 :     is the entire Sapling server.
72 :    
73 :     package SAPserver;
74 :     use strict;
75 :     use base qw(ClientThing);
76 : parrello 1.30
77 : parrello 1.1 sub new {
78 :     my ($class, %options) = @_;
79 :     $options{url} = 'http://servers.nmpdr.org/sapling/server.cgi' if ! defined $options{url};
80 : parrello 1.2 return $class->SUPER::new('SAP', %options);
81 : parrello 1.1 }
82 : parrello 1.30
83 : parrello 1.1 1;
84 :    
85 :     Most methods that the server will support are then handled automatically by the
86 :     this class's AUTOLOAD.
87 :    
88 :     =head3 File-Based Data Transfer
89 :    
90 :     Most server methods take YAML input and produce YAML output. In some cases,
91 :     however, the size of the input or output precludes packaging everything into
92 :     strings for passage directly across the network. For this reason, the utility
93 :     methods L<_send_file> and L<_receive_file> have been provided. These allow
94 :     entire files of data to be sent and received piecemeal. Methods that require
95 :     this capability will need to be specified explicitly in the subclass rather than
96 :     relying on the AUTOLOAD.
97 :    
98 : parrello 1.2 NOTE: This facility was intended to provide flow control for calls to the
99 :     B<query> method in the Sapling Server, but it has never actually been
100 :     implemented.
101 :    
102 : parrello 1.1 =cut
103 :    
104 :     # Number of bytes to transfer in a data chunk.
105 :     use constant CHUNKSIZE => 512*1024;
106 :    
107 :     =head2 Main Object Methods
108 :    
109 :     =head3 new
110 :    
111 :     my $ss = ClientThing->new($type, %options);
112 :    
113 :     Construct a new server object. The I<$type> parameter should be the server type
114 :     (e.g. C<SAP> for the Sapling server, C<FFfunctions> for the FIGfams server). The
115 :     following options are supported.
116 :    
117 :     =over 4
118 :    
119 :     =item url
120 :    
121 :     URL for the server. This option is required.
122 :    
123 :     =item singleton (optional)
124 :    
125 :     If TRUE, results from methods will be returned in singleton mode. In singleton
126 :     mode, if a single result comes back, it will come back as a scalar rather than
127 :     as a hash value accessible via an incoming ID.
128 :    
129 :     =back
130 :    
131 :     =cut
132 :    
133 :     sub new {
134 :     # Get the parameters.
135 :     my ($class, $type, %options) = @_;
136 :     # Turn off YAML compression, which causes problems with our hash keys.
137 :     $YAML::CompressSeries = 0;
138 :     # Get the options.
139 :     my $url = $options{url};
140 :     my $singleton = $options{singleton} || 0;
141 :     # Create the fields of the object. Note that if we're in localhost mode,
142 :     # the user agent is actually a SAP object.
143 :     my $server_url = $url;
144 :     my $ua;
145 :     if ($server_url ne 'localhost') {
146 : parrello 1.6 # Create the user agent.
147 : parrello 1.1 require LWP::UserAgent;
148 :     $ua = LWP::UserAgent->new();
149 : olson 1.17 $ua->agent(AGENT_NAME . " ($^O $^V)");
150 : olson 1.25 # Set the default timeout to 20 minutes.
151 :     my $timeout = 20 * 60;
152 :     if (exists($ENV{SAS_TIMEOUT}))
153 :     {
154 :     $timeout = $ENV{SAS_TIMEOUT};
155 :     }
156 :     $ua->timeout($timeout);
157 : parrello 1.1 } else {
158 : parrello 1.6 # Get access to the server package.
159 : parrello 1.27 my $package = $type;
160 :     $package =~ s/::/\//g;
161 :     require "$package.pm";
162 : parrello 1.6 # Create a service object.
163 : parrello 1.18 $ua = eval("$type->new(\$options{sapDB})");
164 : parrello 1.1 if ($@) {
165 :     die "Error creating $type object: $@";
166 :     }
167 :     }
168 : olson 1.23 my $accept_encoding = [];
169 :     eval {
170 :     my $can_accept = HTTP::Message::decodable();
171 :     @$accept_encoding = ('Accept-Encoding' => $can_accept);
172 :     };
173 :    
174 : parrello 1.1 # Create the server object.
175 : parrello 1.30 my $retVal = {
176 : parrello 1.1 server_url => $server_url,
177 :     ua => $ua,
178 :     singleton => $singleton,
179 : olson 1.23 accept_encoding => $accept_encoding,
180 : parrello 1.16 dbName => undef,
181 : parrello 1.1 };
182 : parrello 1.2 # Bless it.
183 : parrello 1.1 bless $retVal, $class;
184 : parrello 1.2 # Get the list of permitted methods from the server.
185 :     my $methodList = $retVal->_call_method(methods => []);
186 :     # Convert it to a hash and store it in this object.
187 : parrello 1.12 $retVal->{methodHash} = { methods => 1, map { $_ => 1 } @$methodList };
188 : parrello 1.2 # Return the object.
189 : parrello 1.1 return $retVal;
190 :     }
191 :    
192 :     =head3 AUTOLOAD
193 :    
194 :     my $result = $server->method(%args);
195 :    
196 :     Call a function on the server. Any method call on this object (other than
197 :     the constructor) is translated into a request against the server. This
198 :     enables us to add new server functions without requiring an update to this
199 :     object or its parent. The parameters are usually specified as a hash, and the
200 :     result is a scalar or object reference. In some cases the parameters are a list.
201 :     To deistinguish between the two cases, all hash keys must begin with hyphens.
202 :    
203 :     If an error occurs, we will throw an exception.
204 :    
205 :     =cut
206 :    
207 :     # This variable will contain the method name.
208 :     our $AUTOLOAD;
209 :    
210 :     sub AUTOLOAD {
211 :     # Get the parameters. We do some fancy dancing to allow the user to pass
212 :     # in a hash, a list, a list reference, or a hash reference.
213 :     my $self = shift @_;
214 :     my $args = $_[0];
215 :     if (defined $args) {
216 :     if (scalar @_ gt 1) {
217 :     # Here we have multiple arguments. We check the first one for a
218 :     # leading hyphen.
219 :     if ($args =~ /^-/) {
220 :     # This means we have hash-form parameters.
221 :     my %args = @_;
222 :     $args = \%args;
223 :     } else {
224 :     # This means we have list-form parameters.
225 :     my @args = @_;
226 :     $args = \@args;
227 :     }
228 :     } else {
229 :     # Here we have a single argument. If it's a scalar, we convert it
230 :     # to a singleton list.
231 :     if (! ref $args) {
232 :     $args = [$args];
233 :     }
234 :     }
235 :     }
236 :     # Declare the return variable.
237 :     my $retVal;
238 :     # Get the method name.
239 :     my $function = $AUTOLOAD;
240 :     # Strip off the stuff before the method name.
241 :     $function =~ s/.+:://;
242 : parrello 1.2 # Validate the method name.
243 :     if (! $self->{methodHash}{$function}) {
244 :     die "Method \"$function\" not supported.";
245 :     } else {
246 :     # Call the method.
247 :     $retVal = $self->_call_method($function, $args);
248 :     # We have our result. Adjust for singleton mode.
249 :     if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
250 :     # Here we're in singleton mode and we got a single result,
251 :     # so we dereference a bit to make it easier for the user
252 :     # to access it.
253 :     ($retVal) = values %$retVal;
254 :     }
255 : parrello 1.1 }
256 :     # Return the result.
257 :     return $retVal;
258 :     }
259 :    
260 :     =head3 DESTROY
261 :    
262 :     $ss->DESTROY();
263 :    
264 :     This method has no function. It's purpose is to keep the destructor from
265 :     being caught by the autoload processing.
266 :    
267 :     =cut
268 :    
269 :     sub DESTROY { }
270 :    
271 : parrello 1.16 =head3 ChangeDB
272 :    
273 :     $server->ChangeDB($newDbName);
274 :    
275 :     Specify the new database for future requests against this object.
276 :    
277 :     =over 4
278 :    
279 :     =item newDbName
280 :    
281 :     The name of the new database.
282 :    
283 :     =back
284 :    
285 :     =cut
286 :    
287 :     sub ChangeDB {
288 :     # Get the parameters.
289 :     my ($self, $newDbName) = @_;
290 :     # Store the new database name.
291 :     $self->{dbName} = $newDbName;
292 :     }
293 :    
294 : parrello 1.1 =head2 Utility Methods
295 :    
296 : parrello 1.14 =head3 ComputeURL
297 :    
298 :     my $url = ClientThing::ComputeURL($url, $cgi, $name);
299 :    
300 :     Compute the URL to use for connecting to this client's server. The default is to
301 :     connect to the annotator SEED script, but the client can request direct calls
302 :     (localhost), a specific URL, the P-SEED, or a specific SEED sandbox.
303 :    
304 :     If a URL is specified, it is returned without preamble.
305 :    
306 :     If no URL is specified, then the C<SAS_SERVER> environment variable is examined for
307 :     the following values.
308 :    
309 :     =over 4
310 :    
311 :     =item localhost
312 :    
313 :     Use direct calls to the server without going through HTTP (only works for the
314 :     Sapling and FBAMODEL servers).
315 :    
316 : parrello 1.28 =item PUBSEED (default)
317 : parrello 1.14
318 : parrello 1.28 Use the main servers for the public SEED data.
319 :    
320 :     =item SEED
321 :    
322 :     Use the annotator SEED data. This is much more restricted.
323 : parrello 1.14
324 :     =item PSEED
325 :    
326 :     Use the alternate servers for the PSEED data.
327 :    
328 :     =item (other)
329 :    
330 :     In this case, the value will be assumed to be the URL of a SEED sandbox, and the
331 :     appropriate script in that sandbox will be used.
332 :    
333 :     =back
334 :    
335 :     The parameters are as follows:
336 :    
337 :     =over 4
338 :    
339 :     =item url (optional)
340 :    
341 :     URL to use, if specified.
342 :    
343 :     =item cgi
344 :    
345 :     Name of the CGI script to use if a SEED sandbox is requested (e.g. C<sap_server.cgi>,
346 :     C<anno_server.cgi>).
347 :    
348 :     =item name
349 :    
350 :     Name of the pseudo-directory to use if a server is requested (e.g. C<sapling>, C<anno>).
351 :    
352 :     =item RETURN
353 :    
354 :     Returns the URL to pass to the server interface object constructor.
355 :    
356 :     =back
357 :    
358 :     =cut
359 :    
360 :     sub ComputeURL {
361 :     # Get the parameters.
362 :     my ($url, $cgi, $name) = @_;
363 :     # Do we have an explicit URL?
364 :     my $retVal = $url;
365 :     if (! $retVal) {
366 :     # No. Check the environment variable.
367 : olson 1.20 my $envParm = $ENV{SAS_SERVER} || 'PUBSEED';
368 : parrello 1.14 if ($envParm eq 'SEED') {
369 :     $retVal = "http://servers.nmpdr.org/$name/server.cgi";
370 :     } elsif ($envParm eq 'PSEED') {
371 :     $retVal = "http://servers.nmpdr.org/pseed/$name/server.cgi";
372 : olson 1.19 } elsif ($envParm eq 'PUBSEED') {
373 :     $retVal = "http://pubseed.theseed.org/$name/server.cgi";
374 : olson 1.29 } elsif ($envParm eq 'PUBSEED_TEST') {
375 :     $retVal = "http://pubseed.theseed.org/saptest/$name/server.cgi";
376 : parrello 1.32 } elsif ($envParm eq 'CORE') {
377 :     my $lcName = lc $name;
378 :     $retVal = "http://core.theseed.org/FIG/$cgi";
379 : parrello 1.14 } elsif ($envParm eq 'localhost') {
380 :     $retVal = 'localhost';
381 :     } else {
382 :     # Here we have a SEED sandbox. Check for the trailing slash.
383 :     $retVal = $envParm;
384 :     unless ($retVal =~ m#/$#) {
385 :     $retVal .= "/";
386 :     }
387 :     # Check for the HTTP prefix.
388 :     unless ($retVal =~ m#^http://#i) {
389 :     $retVal = "http://$retVal";
390 :     }
391 :     # Append the script name.
392 :     $retVal .= $cgi;
393 :     }
394 :     }
395 :     # Return the computed URL.
396 :     return $retVal;
397 :     }
398 :    
399 : parrello 1.15 =head3 FixOptions
400 :    
401 :     my %options = ClientThing::FixOptions(@options);
402 :    
403 :     This method allows more options for the specification of parameters to a server's
404 :     client module. First, the input can be specified as a hash or a hash reference,
405 :     and the keys can optionally have hyphens prefixed. (So, for example, the key
406 :     C<-url> would be converted to C<url>.)
407 :    
408 :     =cut
409 :    
410 :     sub FixOptions {
411 :     # Get the parameters.
412 :     my (@options) = @_;
413 :     # Create the return hash.
414 :     my %retVal;
415 :     if (@options == 1 && ref $options[0] eq 'HASH') {
416 :     my $optionHash = $options[0];
417 :     # Here the user specified a hash reference. Transfer its to
418 :     # the return hash, removing hyphens from key names.
419 :     for my $key (keys %$optionHash) {
420 :     if ($key =~ /^-(.+)/) {
421 :     $retVal{$1} = $optionHash->{$key};
422 :     } else {
423 :     $retVal{$key} = $optionHash->{$key};
424 :     }
425 :     }
426 :     } else {
427 :     # Here the user specified a regular hash. We need to convert it
428 :     # from a list.
429 :     for (my $i = 0; $i < @options; $i += 2) {
430 :     # Get the key of the current pair.
431 :     my $key = $options[$i];
432 :     # Strip off the hyphen (if any).
433 :     if ($key =~ /^-(.+)/) {
434 :     $key = $1;
435 :     }
436 :     # Store the value with the key in the output hash.
437 :     $retVal{$key} = $options[$i + 1];
438 :     }
439 :     }
440 :     # Return the computed hash.
441 :     return %retVal;
442 :     }
443 :    
444 : parrello 1.1 =head3 _call_method
445 :    
446 :     my $result = $server->_call_method($method, $args);
447 :    
448 :     Call the specified method on the server with the specified arguments and
449 :     return the result. The arguments must already be packaged as a hash or
450 :     list reference. This method is the heart of the AUTOLOAD method, and is
451 :     provided as a utility for specialized methods that can't use the AUTOLOAD
452 :     facility.
453 :    
454 :     =over 4
455 :    
456 :     =item method
457 :    
458 :     Name of the server function being invoked.
459 :    
460 :     =item args
461 :    
462 :     Argument object to pass to the function.
463 :    
464 :     =item RETURN
465 :    
466 :     Returns a hash or list reference with the function results.
467 :    
468 :     =back
469 :    
470 :     =cut
471 :    
472 :     sub _call_method {
473 :     # Get the parameters.
474 :     my ($self, $method, $args) = @_;
475 :     # Declare the return variable.
476 :     my $retVal;
477 :     # Get our user agent.
478 :     my $ua = $self->{ua};
479 :     # Determine the type.
480 :     if (ref $ua eq 'LWP::UserAgent') {
481 :     # Here we're going to a server. Compute the argument document.
482 : parrello 1.30 my $argString = YAML::XS::Dump($args);
483 : parrello 1.1 # Request the function from the server.
484 :     my $content = $self->_send_request(function => $method, args => $argString,
485 : parrello 1.30 source => __PACKAGE__, encoding => 'yaml2',
486 : parrello 1.16 dbName => $self->{dbName});
487 : parrello 1.30 $retVal = YAML::XS::Load($content);
488 : parrello 1.1 } else {
489 :     # Here we're calling a local method.
490 :     $retVal = eval("\$ua->$method(\$args)");
491 :     # Check for an error.
492 :     if ($@) {
493 :     die "Package error: $@";
494 :     }
495 :     }
496 :     # Return the result.
497 :     return $retVal;
498 :     }
499 :    
500 :     =head3 _send_file
501 :    
502 :     my $name = $server->_send_file($ih);
503 :    
504 :     Send a file of data to the server and return its name.
505 :    
506 :     =over 4
507 :    
508 :     =item ih
509 :    
510 :     Open input file handle or the name of the input file.
511 :    
512 :     =item RETURN
513 :    
514 :     Returns the name of the file created on the server. This is not the full name
515 :     of the file; rather, it is enough information for the server to find the file
516 :     again when it needs it.
517 :    
518 :     =back
519 :    
520 :     =cut
521 :    
522 :     sub _send_file {
523 :     # Get the parameters.
524 :     my ($self, $ih) = @_;
525 :     # Declare the return variable.
526 :     my $retVal;
527 :     # Get the user agent.
528 :     my $ua = $self->{ua};
529 :     # Find out if we have a handle or a file name. When we're done, we'll have an
530 :     # open handle to the file in $ih_real.
531 :     my $ih_real;
532 :     if (ref $ih eq 'GLOB') {
533 :     $ih_real = $ih;
534 :     } else {
535 :     open $ih_real, "<$ih" || die "File error: $!";
536 :     }
537 :     # Are we in localhost mode?
538 :     if (ref $ua eq 'LWP::UserAgent') {
539 :     # Tell the server to create the file and get the file name back.
540 :     $retVal = $self->_send_request(file => 'create');
541 :     # Loop through the input, reading and sending chunks of data.
542 :     my ($chunk, $rc);
543 :     while (! eof $ih) {
544 :     # Get a chunk of data.
545 :     my $rc = read $ih, $chunk, CHUNKSIZE;
546 :     # Check for errors.
547 :     if (! defined $rc) {
548 :     die "File error: $!";
549 :     } elsif ($rc > 0) {
550 :     # Here we have data to send.
551 :     $self->_send_request(file => 'write', name => $retVal, data => $chunk);
552 :     }
553 :     }
554 :     } else {
555 :     # Here we're in local mode. We need a copy of the file in the FIG temporary
556 :     # directory.
557 :     require File::Temp;
558 :     require FIG_Config;
559 :     my ($oh, $fileName) = File::Temp::tempfile('tempSERVERsendFileXXXXX',
560 :     suffix => 'txt', UNLINK => 1,
561 :     DIR => $FIG_Config::temp);
562 :     # Copy the input file to the output.
563 :     while (! eof $ih) {
564 :     my $line = <$ih_real>;
565 :     print $oh $line;
566 :     }
567 :     close $oh;
568 :     # Return the file name.
569 :     $retVal = $fileName;
570 :     }
571 :     # Return the result.
572 :     return $retVal;
573 :     }
574 :    
575 :     =head3 _receive_file
576 :    
577 :     $server->_receive_file($oh, $name);
578 :    
579 :     Retrieve the named file of data from the server.
580 :    
581 :     =over 4
582 :    
583 :     =item oh
584 :    
585 :     Open file handle to which the data is to be written, or the name of the file to
586 :     contain the data.
587 :    
588 :     =item name
589 :    
590 :     Name of the data file in the FIG temporary directory on the server.
591 :    
592 :     =back
593 :    
594 :     =cut
595 :    
596 :     sub _receive_file {
597 :     # Get the parameters.
598 :     my ($self, $oh, $name) = @_;
599 :     # Get the user agent.
600 :     my $ua = $self->{ua};
601 :     # Find out if we have a handle or a file name. When we're done, we'll have
602 :     # an open handle to the file in $oh_real.
603 :     my $oh_real;
604 :     if (ref $oh eq 'GLOB') {
605 :     $oh_real = $oh;
606 :     } else {
607 :     open $oh_real, ">$oh" || die "File error: $!";
608 :     }
609 :     # Are we in localhost mode?
610 :     if (ref $ua eq 'LWP::UserAgent') {
611 :     # No, we must get this file from the server. Tell the server to get us
612 :     # the length of the file.
613 :     my $length = $self->_send_request(file => 'open', name => $name);
614 :     # Loop through the file, reading chunks.
615 :     my $location = 0;
616 :     while ($location < $length) {
617 :     my $chunk = $self->_send_request(file => 'read', name => $name,
618 :     location => $location, size => CHUNKSIZE);
619 :     print $oh_real $chunk;
620 :     $location += length $chunk;
621 :     }
622 :     } else {
623 :     # Open the named file for input.
624 :     require FIG_Config;
625 :     open my $ih, "<$FIG_Config::temp/$name";
626 :     # Copy it to the output.
627 :     while (! eof $ih) {
628 :     my $line = <$ih>;
629 :     print $oh_real $line;
630 :     }
631 :     }
632 :     # If we opened the output file ourselves, close it.
633 :     if (ref $oh ne 'GLOB') {
634 :     close $oh_real;
635 :     }
636 :     }
637 :    
638 :    
639 :     =head3 _send_request
640 :    
641 :     my $result = $server->_send_request(%parms);
642 :    
643 :     Send a request to the server. This method must not be called in localhost
644 :     mode. If an error occurs, this method will die; otherwise, the content of
645 :     the response will be passed back as the result.
646 :    
647 :     =over 4
648 :    
649 :     =item parms
650 :    
651 :     Hash of CGI parameters to send to the server.
652 :    
653 :     =item RETURN
654 :    
655 :     Returns the string returned by the server in response to the request.
656 :    
657 :     =back
658 :    
659 :     =cut
660 :    
661 :     sub _send_request {
662 :     # Get the parameters.
663 : olson 1.26 my ($self, @parms) = @_;
664 : parrello 1.1 # Get the user agent.
665 :     my $ua = $self->{ua};
666 :     # Request the function from the server. Note that the hash is actually passed
667 :     # as a list reference.
668 : olson 1.4 #
669 :     # retries is the set of retry wait times in seconds we should use. when
670 :     # we run out the call will fail.
671 :     #
672 :    
673 :     my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
674 : olson 1.25 my %codes_to_retry = map { $_ => 1 } qw(110 408 502 503 504 200) ;
675 : olson 1.4 my $response;
676 :    
677 : olson 1.26 my $parms;
678 :     if (@parms == 1 && ref($parms[0]))
679 :     {
680 :     $parms = $parms[0];
681 :     }
682 :     else
683 :     {
684 :     $parms = [@parms];
685 :     }
686 :    
687 : parrello 1.11 while (1) {
688 : olson 1.26 $response = $ua->post($self->{server_url}, $parms,
689 : olson 1.23 @{$self->{accept_encoding}},
690 : olson 1.20 );
691 : parrello 1.11 if ($response->is_success) {
692 : olson 1.20 my $retVal = $response->decoded_content;
693 : parrello 1.11 return $retVal;
694 :     }
695 : olson 1.4
696 : parrello 1.11 #
697 :     # If this is not one of the error codes we retry for, or if we
698 :     # are out of retries, fail immediately
699 :     #
700 : olson 1.25
701 : parrello 1.11 my $code = $response->code;
702 : olson 1.25 my $msg = $response->message;
703 :     my $want_retry = 0;
704 :     if ($codes_to_retry{$code})
705 :     {
706 :     $want_retry = 1;
707 :     }
708 : golsen 1.31 elsif ($code eq 500 && defined( $response->header('client-warning') )
709 :     && $response->header('client-warning') eq 'Internal response')
710 : olson 1.25 {
711 :     #
712 :     # Handle errors that were not thrown by the web
713 :     # server but rather picked up by the client library.
714 :     #
715 : olson 1.29 # If we got a client timeout or connection refused, let us retry.
716 : olson 1.25 #
717 :    
718 : olson 1.29 if ($msg =~ /timeout|connection refused/i)
719 : olson 1.25 {
720 :     $want_retry = 1;
721 :     }
722 : parrello 1.30
723 : olson 1.25 }
724 : parrello 1.30
725 : olson 1.25 if (!$want_retry || @retries == 0) {
726 : parrello 1.6 if ($ENV{SAS_DEBUG}) {
727 : parrello 1.13 my $content = $response->content;
728 :     if (! $content) {
729 :     $content = "Unknown error from server.";
730 :     }
731 :     confess $content;
732 : parrello 1.6 } else {
733 : parrello 1.9 confess $response->status_line;
734 : parrello 1.6 }
735 : parrello 1.11 }
736 : parrello 1.30
737 : parrello 1.11 #
738 :     # otherwise, sleep & loop.
739 :     #
740 :     my $retry_time = shift(@retries);
741 : olson 1.25 print STDERR strftime("%F %T", localtime), ": Request failed with code=$code msg=$msg, sleeping $retry_time and retrying\n";
742 : parrello 1.11 sleep($retry_time);
743 : olson 1.4
744 : parrello 1.1 }
745 : olson 1.4
746 :     #
747 :     # Should never get here.
748 :     #
749 : parrello 1.1 }
750 :    
751 :    
752 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3