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

Annotation of /FigKernelPackages/ClientThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :     use strict;
3 :    
4 :     #!/usr/bin/perl -w
5 :     #
6 :     # This is a SAS Component.
7 :     #
8 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
9 :     # for Interpretations of Genomes. All Rights Reserved.
10 :     #
11 :     # This file is part of the SEED Toolkit.
12 :     #
13 :     # The SEED Toolkit is free software. You can redistribute
14 :     # it and/or modify it under the terms of the SEED Toolkit
15 :     # Public License.
16 :     #
17 :     # You should have received a copy of the SEED Toolkit Public License
18 :     # along with this program; if not write to the University of Chicago
19 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
20 :     # Genomes at veronika@thefig.info or download a copy from
21 :     # http://www.theseed.org/LICENSE.TXT.
22 :     #
23 :    
24 :     package ClientThing;
25 :    
26 :     use strict;
27 :     use YAML;
28 : parrello 1.2 use ErrorMessage;
29 : parrello 1.6 use Carp;
30 : parrello 1.1 no warnings qw(once);
31 : olson 1.10 use POSIX;
32 : parrello 1.1
33 :     =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 :    
77 :     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 :    
83 :     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 : parrello 1.6 # Set the timeout to 20 minutes.
150 :     $ua->timeout(20 * 60);
151 : parrello 1.1 } else {
152 : parrello 1.6 # Get access to the server package.
153 : parrello 1.1 require "$type.pm";
154 : parrello 1.6 # Create a service object.
155 : parrello 1.1 $ua = eval("$type->new()");
156 :     if ($@) {
157 :     die "Error creating $type object: $@";
158 :     }
159 :     }
160 :     # Create the server object.
161 :     my $retVal = {
162 :     server_url => $server_url,
163 :     ua => $ua,
164 :     singleton => $singleton,
165 :     };
166 : parrello 1.2 # Bless it.
167 : parrello 1.1 bless $retVal, $class;
168 : parrello 1.2 # Get the list of permitted methods from the server.
169 :     my $methodList = $retVal->_call_method(methods => []);
170 :     # Convert it to a hash and store it in this object.
171 : parrello 1.12 $retVal->{methodHash} = { methods => 1, map { $_ => 1 } @$methodList };
172 : parrello 1.2 # Return the object.
173 : parrello 1.1 return $retVal;
174 :     }
175 :    
176 :     =head3 AUTOLOAD
177 :    
178 :     my $result = $server->method(%args);
179 :    
180 :     Call a function on the server. Any method call on this object (other than
181 :     the constructor) is translated into a request against the server. This
182 :     enables us to add new server functions without requiring an update to this
183 :     object or its parent. The parameters are usually specified as a hash, and the
184 :     result is a scalar or object reference. In some cases the parameters are a list.
185 :     To deistinguish between the two cases, all hash keys must begin with hyphens.
186 :    
187 :     If an error occurs, we will throw an exception.
188 :    
189 :     =cut
190 :    
191 :     # This variable will contain the method name.
192 :     our $AUTOLOAD;
193 :    
194 :     sub AUTOLOAD {
195 :     # Get the parameters. We do some fancy dancing to allow the user to pass
196 :     # in a hash, a list, a list reference, or a hash reference.
197 :     my $self = shift @_;
198 :     my $args = $_[0];
199 :     if (defined $args) {
200 :     if (scalar @_ gt 1) {
201 :     # Here we have multiple arguments. We check the first one for a
202 :     # leading hyphen.
203 :     if ($args =~ /^-/) {
204 :     # This means we have hash-form parameters.
205 :     my %args = @_;
206 :     $args = \%args;
207 :     } else {
208 :     # This means we have list-form parameters.
209 :     my @args = @_;
210 :     $args = \@args;
211 :     }
212 :     } else {
213 :     # Here we have a single argument. If it's a scalar, we convert it
214 :     # to a singleton list.
215 :     if (! ref $args) {
216 :     $args = [$args];
217 :     }
218 :     }
219 :     }
220 :     # Declare the return variable.
221 :     my $retVal;
222 :     # Get the method name.
223 :     my $function = $AUTOLOAD;
224 :     # Strip off the stuff before the method name.
225 :     $function =~ s/.+:://;
226 : parrello 1.2 # Validate the method name.
227 :     if (! $self->{methodHash}{$function}) {
228 :     die "Method \"$function\" not supported.";
229 :     } else {
230 :     # Call the method.
231 :     $retVal = $self->_call_method($function, $args);
232 :     # We have our result. Adjust for singleton mode.
233 :     if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
234 :     # Here we're in singleton mode and we got a single result,
235 :     # so we dereference a bit to make it easier for the user
236 :     # to access it.
237 :     ($retVal) = values %$retVal;
238 :     }
239 : parrello 1.1 }
240 :     # Return the result.
241 :     return $retVal;
242 :     }
243 :    
244 :     =head3 DESTROY
245 :    
246 :     $ss->DESTROY();
247 :    
248 :     This method has no function. It's purpose is to keep the destructor from
249 :     being caught by the autoload processing.
250 :    
251 :     =cut
252 :    
253 :     sub DESTROY { }
254 :    
255 :     =head2 Utility Methods
256 :    
257 :     =head3 _call_method
258 :    
259 :     my $result = $server->_call_method($method, $args);
260 :    
261 :     Call the specified method on the server with the specified arguments and
262 :     return the result. The arguments must already be packaged as a hash or
263 :     list reference. This method is the heart of the AUTOLOAD method, and is
264 :     provided as a utility for specialized methods that can't use the AUTOLOAD
265 :     facility.
266 :    
267 :     =over 4
268 :    
269 :     =item method
270 :    
271 :     Name of the server function being invoked.
272 :    
273 :     =item args
274 :    
275 :     Argument object to pass to the function.
276 :    
277 :     =item RETURN
278 :    
279 :     Returns a hash or list reference with the function results.
280 :    
281 :     =back
282 :    
283 :     =cut
284 :    
285 :     sub _call_method {
286 :     # Get the parameters.
287 :     my ($self, $method, $args) = @_;
288 :     # Declare the return variable.
289 :     my $retVal;
290 :     # Get our user agent.
291 :     my $ua = $self->{ua};
292 :     # Determine the type.
293 :     if (ref $ua eq 'LWP::UserAgent') {
294 :     # Here we're going to a server. Compute the argument document.
295 :     my $argString = YAML::Dump($args);
296 :     # Request the function from the server.
297 :     my $content = $self->_send_request(function => $method, args => $argString,
298 :     source => __PACKAGE__);
299 :     $retVal = YAML::Load($content);
300 :     } else {
301 :     # Here we're calling a local method.
302 :     $retVal = eval("\$ua->$method(\$args)");
303 :     # Check for an error.
304 :     if ($@) {
305 :     die "Package error: $@";
306 :     }
307 :     }
308 :     # Return the result.
309 :     return $retVal;
310 :     }
311 :    
312 :     =head3 _send_file
313 :    
314 :     my $name = $server->_send_file($ih);
315 :    
316 :     Send a file of data to the server and return its name.
317 :    
318 :     =over 4
319 :    
320 :     =item ih
321 :    
322 :     Open input file handle or the name of the input file.
323 :    
324 :     =item RETURN
325 :    
326 :     Returns the name of the file created on the server. This is not the full name
327 :     of the file; rather, it is enough information for the server to find the file
328 :     again when it needs it.
329 :    
330 :     =back
331 :    
332 :     =cut
333 :    
334 :     sub _send_file {
335 :     # Get the parameters.
336 :     my ($self, $ih) = @_;
337 :     # Declare the return variable.
338 :     my $retVal;
339 :     # Get the user agent.
340 :     my $ua = $self->{ua};
341 :     # Find out if we have a handle or a file name. When we're done, we'll have an
342 :     # open handle to the file in $ih_real.
343 :     my $ih_real;
344 :     if (ref $ih eq 'GLOB') {
345 :     $ih_real = $ih;
346 :     } else {
347 :     open $ih_real, "<$ih" || die "File error: $!";
348 :     }
349 :     # Are we in localhost mode?
350 :     if (ref $ua eq 'LWP::UserAgent') {
351 :     # Tell the server to create the file and get the file name back.
352 :     $retVal = $self->_send_request(file => 'create');
353 :     # Loop through the input, reading and sending chunks of data.
354 :     my ($chunk, $rc);
355 :     while (! eof $ih) {
356 :     # Get a chunk of data.
357 :     my $rc = read $ih, $chunk, CHUNKSIZE;
358 :     # Check for errors.
359 :     if (! defined $rc) {
360 :     die "File error: $!";
361 :     } elsif ($rc > 0) {
362 :     # Here we have data to send.
363 :     $self->_send_request(file => 'write', name => $retVal, data => $chunk);
364 :     }
365 :     }
366 :     } else {
367 :     # Here we're in local mode. We need a copy of the file in the FIG temporary
368 :     # directory.
369 :     require File::Temp;
370 :     require FIG_Config;
371 :     my ($oh, $fileName) = File::Temp::tempfile('tempSERVERsendFileXXXXX',
372 :     suffix => 'txt', UNLINK => 1,
373 :     DIR => $FIG_Config::temp);
374 :     # Copy the input file to the output.
375 :     while (! eof $ih) {
376 :     my $line = <$ih_real>;
377 :     print $oh $line;
378 :     }
379 :     close $oh;
380 :     # Return the file name.
381 :     $retVal = $fileName;
382 :     }
383 :     # Return the result.
384 :     return $retVal;
385 :     }
386 :    
387 :     =head3 _receive_file
388 :    
389 :     $server->_receive_file($oh, $name);
390 :    
391 :     Retrieve the named file of data from the server.
392 :    
393 :     =over 4
394 :    
395 :     =item oh
396 :    
397 :     Open file handle to which the data is to be written, or the name of the file to
398 :     contain the data.
399 :    
400 :     =item name
401 :    
402 :     Name of the data file in the FIG temporary directory on the server.
403 :    
404 :     =back
405 :    
406 :     =cut
407 :    
408 :     sub _receive_file {
409 :     # Get the parameters.
410 :     my ($self, $oh, $name) = @_;
411 :     # Get the user agent.
412 :     my $ua = $self->{ua};
413 :     # Find out if we have a handle or a file name. When we're done, we'll have
414 :     # an open handle to the file in $oh_real.
415 :     my $oh_real;
416 :     if (ref $oh eq 'GLOB') {
417 :     $oh_real = $oh;
418 :     } else {
419 :     open $oh_real, ">$oh" || die "File error: $!";
420 :     }
421 :     # Are we in localhost mode?
422 :     if (ref $ua eq 'LWP::UserAgent') {
423 :     # No, we must get this file from the server. Tell the server to get us
424 :     # the length of the file.
425 :     my $length = $self->_send_request(file => 'open', name => $name);
426 :     # Loop through the file, reading chunks.
427 :     my $location = 0;
428 :     while ($location < $length) {
429 :     my $chunk = $self->_send_request(file => 'read', name => $name,
430 :     location => $location, size => CHUNKSIZE);
431 :     print $oh_real $chunk;
432 :     $location += length $chunk;
433 :     }
434 :     } else {
435 :     # Open the named file for input.
436 :     require FIG_Config;
437 :     open my $ih, "<$FIG_Config::temp/$name";
438 :     # Copy it to the output.
439 :     while (! eof $ih) {
440 :     my $line = <$ih>;
441 :     print $oh_real $line;
442 :     }
443 :     }
444 :     # If we opened the output file ourselves, close it.
445 :     if (ref $oh ne 'GLOB') {
446 :     close $oh_real;
447 :     }
448 :     }
449 :    
450 :    
451 :     =head3 _send_request
452 :    
453 :     my $result = $server->_send_request(%parms);
454 :    
455 :     Send a request to the server. This method must not be called in localhost
456 :     mode. If an error occurs, this method will die; otherwise, the content of
457 :     the response will be passed back as the result.
458 :    
459 :     =over 4
460 :    
461 :     =item parms
462 :    
463 :     Hash of CGI parameters to send to the server.
464 :    
465 :     =item RETURN
466 :    
467 :     Returns the string returned by the server in response to the request.
468 :    
469 :     =back
470 :    
471 :     =cut
472 :    
473 :     sub _send_request {
474 :     # Get the parameters.
475 :     my ($self, %parms) = @_;
476 :     # Get the user agent.
477 :     my $ua = $self->{ua};
478 :     # Request the function from the server. Note that the hash is actually passed
479 :     # as a list reference.
480 : olson 1.4 #
481 :     # retries is the set of retry wait times in seconds we should use. when
482 :     # we run out the call will fail.
483 :     #
484 :    
485 :     my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
486 : olson 1.5 my %codes_to_retry = map { $_ => 1 } qw(110 408 502 503 504 200) ;
487 : olson 1.4 my $response;
488 :    
489 : parrello 1.11 while (1) {
490 :     $response = $ua->post($self->{server_url}, [ %parms ]);
491 :     if ($response->is_success) {
492 :     my $retVal = $response->content;
493 :     return $retVal;
494 :     }
495 : olson 1.4
496 : parrello 1.11 #
497 :     # If this is not one of the error codes we retry for, or if we
498 :     # are out of retries, fail immediately
499 :     #
500 :     my $code = $response->code;
501 :     if (!$codes_to_retry{$code} || @retries == 0) {
502 : parrello 1.6 if ($ENV{SAS_DEBUG}) {
503 : parrello 1.8 confess $response->content;
504 : parrello 1.6 } else {
505 : parrello 1.9 confess $response->status_line;
506 : parrello 1.6 }
507 : parrello 1.11 }
508 :    
509 :     #
510 :     # otherwise, sleep & loop.
511 :     #
512 :     my $retry_time = shift(@retries);
513 :     print STDERR strftime("%F %T", localtime), ": Request failed with code=$code, sleeping $retry_time and retrying\n";
514 :     sleep($retry_time);
515 : olson 1.4
516 : parrello 1.1 }
517 : olson 1.4
518 :     #
519 :     # Should never get here.
520 :     #
521 : parrello 1.1 }
522 :    
523 :    
524 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3