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

Annotation of /FigKernelPackages/ClientThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (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 :    
32 :     =head1 Base Class for Server Helper Objects
33 :    
34 :     =head2 Description
35 :    
36 :     This object is used as the base class for the various server objects. It provides
37 :     the functions needed to invoke one of the servers.
38 :    
39 :     This package deliberately uses no internal SEED packages or scripts, only common
40 :     PERL modules.
41 :    
42 :     The fields in this object are as follows.
43 :    
44 :     =over 4
45 :    
46 :     =item server_url
47 :    
48 :     The URL used to request data from the sapling server. If C<localhost> is
49 :     specified, then the L<SAP> module will be called directly.
50 :    
51 :     =item ua
52 :    
53 :     The user agent for communication with the server.
54 :    
55 :     =item singleton
56 :    
57 :     Indicates whether or not results are to be returned in singleton mode. In
58 :     singleton mode, if the return document is a hash reference with only one
59 :     entry, the entry value is returned rather than the hash.
60 :    
61 : parrello 1.2 =item methodHash
62 :    
63 :     Reference to a hash keyed by the names of the server's permissible methods.
64 :    
65 : parrello 1.1 =back
66 :    
67 :     =head2 Creating a Server Client Package
68 :    
69 :     The code to create a server client package is simple. The following program
70 :     is the entire Sapling server.
71 :    
72 :     package SAPserver;
73 :     use strict;
74 :     use base qw(ClientThing);
75 :    
76 :     sub new {
77 :     my ($class, %options) = @_;
78 :     $options{url} = 'http://servers.nmpdr.org/sapling/server.cgi' if ! defined $options{url};
79 : parrello 1.2 return $class->SUPER::new('SAP', %options);
80 : parrello 1.1 }
81 :    
82 :     1;
83 :    
84 :     Most methods that the server will support are then handled automatically by the
85 :     this class's AUTOLOAD.
86 :    
87 :     =head3 File-Based Data Transfer
88 :    
89 :     Most server methods take YAML input and produce YAML output. In some cases,
90 :     however, the size of the input or output precludes packaging everything into
91 :     strings for passage directly across the network. For this reason, the utility
92 :     methods L<_send_file> and L<_receive_file> have been provided. These allow
93 :     entire files of data to be sent and received piecemeal. Methods that require
94 :     this capability will need to be specified explicitly in the subclass rather than
95 :     relying on the AUTOLOAD.
96 :    
97 : parrello 1.2 NOTE: This facility was intended to provide flow control for calls to the
98 :     B<query> method in the Sapling Server, but it has never actually been
99 :     implemented.
100 :    
101 : parrello 1.1 =cut
102 :    
103 :     # Number of bytes to transfer in a data chunk.
104 :     use constant CHUNKSIZE => 512*1024;
105 :    
106 :     =head2 Main Object Methods
107 :    
108 :     =head3 new
109 :    
110 :     my $ss = ClientThing->new($type, %options);
111 :    
112 :     Construct a new server object. The I<$type> parameter should be the server type
113 :     (e.g. C<SAP> for the Sapling server, C<FFfunctions> for the FIGfams server). The
114 :     following options are supported.
115 :    
116 :     =over 4
117 :    
118 :     =item url
119 :    
120 :     URL for the server. This option is required.
121 :    
122 :     =item singleton (optional)
123 :    
124 :     If TRUE, results from methods will be returned in singleton mode. In singleton
125 :     mode, if a single result comes back, it will come back as a scalar rather than
126 :     as a hash value accessible via an incoming ID.
127 :    
128 :     =back
129 :    
130 :     =cut
131 :    
132 :     sub new {
133 :     # Get the parameters.
134 :     my ($class, $type, %options) = @_;
135 :     # Turn off YAML compression, which causes problems with our hash keys.
136 :     $YAML::CompressSeries = 0;
137 :     # Get the options.
138 :     my $url = $options{url};
139 :     my $singleton = $options{singleton} || 0;
140 :     # Create the fields of the object. Note that if we're in localhost mode,
141 :     # the user agent is actually a SAP object.
142 :     my $server_url = $url;
143 :     my $ua;
144 :     if ($server_url ne 'localhost') {
145 : parrello 1.6 # Create the user agent.
146 : parrello 1.1 require LWP::UserAgent;
147 :     $ua = LWP::UserAgent->new();
148 : parrello 1.6 # Set the timeout to 20 minutes.
149 :     $ua->timeout(20 * 60);
150 : parrello 1.1 } else {
151 : parrello 1.6 # Get access to the server package.
152 : parrello 1.1 require "$type.pm";
153 : parrello 1.6 # Create a service object.
154 : parrello 1.1 $ua = eval("$type->new()");
155 :     if ($@) {
156 :     die "Error creating $type object: $@";
157 :     }
158 :     }
159 :     # Create the server object.
160 :     my $retVal = {
161 :     server_url => $server_url,
162 :     ua => $ua,
163 :     singleton => $singleton,
164 :     };
165 : parrello 1.2 # Bless it.
166 : parrello 1.1 bless $retVal, $class;
167 : parrello 1.2 # Get the list of permitted methods from the server.
168 :     my $methodList = $retVal->_call_method(methods => []);
169 :     # Convert it to a hash and store it in this object.
170 :     $retVal->{methodHash} = { map { $_ => 1 } @$methodList };
171 :     # Return the object.
172 : parrello 1.1 return $retVal;
173 :     }
174 :    
175 :     =head3 AUTOLOAD
176 :    
177 :     my $result = $server->method(%args);
178 :    
179 :     Call a function on the server. Any method call on this object (other than
180 :     the constructor) is translated into a request against the server. This
181 :     enables us to add new server functions without requiring an update to this
182 :     object or its parent. The parameters are usually specified as a hash, and the
183 :     result is a scalar or object reference. In some cases the parameters are a list.
184 :     To deistinguish between the two cases, all hash keys must begin with hyphens.
185 :    
186 :     If an error occurs, we will throw an exception.
187 :    
188 :     =cut
189 :    
190 :     # This variable will contain the method name.
191 :     our $AUTOLOAD;
192 :    
193 :     sub AUTOLOAD {
194 :     # Get the parameters. We do some fancy dancing to allow the user to pass
195 :     # in a hash, a list, a list reference, or a hash reference.
196 :     my $self = shift @_;
197 :     my $args = $_[0];
198 :     if (defined $args) {
199 :     if (scalar @_ gt 1) {
200 :     # Here we have multiple arguments. We check the first one for a
201 :     # leading hyphen.
202 :     if ($args =~ /^-/) {
203 :     # This means we have hash-form parameters.
204 :     my %args = @_;
205 :     $args = \%args;
206 :     } else {
207 :     # This means we have list-form parameters.
208 :     my @args = @_;
209 :     $args = \@args;
210 :     }
211 :     } else {
212 :     # Here we have a single argument. If it's a scalar, we convert it
213 :     # to a singleton list.
214 :     if (! ref $args) {
215 :     $args = [$args];
216 :     }
217 :     }
218 :     }
219 :     # Declare the return variable.
220 :     my $retVal;
221 :     # Get the method name.
222 :     my $function = $AUTOLOAD;
223 :     # Strip off the stuff before the method name.
224 :     $function =~ s/.+:://;
225 : parrello 1.2 # Validate the method name.
226 :     if (! $self->{methodHash}{$function}) {
227 :     die "Method \"$function\" not supported.";
228 :     } else {
229 :     # Call the method.
230 :     $retVal = $self->_call_method($function, $args);
231 :     # We have our result. Adjust for singleton mode.
232 :     if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
233 :     # Here we're in singleton mode and we got a single result,
234 :     # so we dereference a bit to make it easier for the user
235 :     # to access it.
236 :     ($retVal) = values %$retVal;
237 :     }
238 : parrello 1.1 }
239 :     # Return the result.
240 :     return $retVal;
241 :     }
242 :    
243 :     =head3 DESTROY
244 :    
245 :     $ss->DESTROY();
246 :    
247 :     This method has no function. It's purpose is to keep the destructor from
248 :     being caught by the autoload processing.
249 :    
250 :     =cut
251 :    
252 :     sub DESTROY { }
253 :    
254 :     =head2 Utility Methods
255 :    
256 :     =head3 _call_method
257 :    
258 :     my $result = $server->_call_method($method, $args);
259 :    
260 :     Call the specified method on the server with the specified arguments and
261 :     return the result. The arguments must already be packaged as a hash or
262 :     list reference. This method is the heart of the AUTOLOAD method, and is
263 :     provided as a utility for specialized methods that can't use the AUTOLOAD
264 :     facility.
265 :    
266 :     =over 4
267 :    
268 :     =item method
269 :    
270 :     Name of the server function being invoked.
271 :    
272 :     =item args
273 :    
274 :     Argument object to pass to the function.
275 :    
276 :     =item RETURN
277 :    
278 :     Returns a hash or list reference with the function results.
279 :    
280 :     =back
281 :    
282 :     =cut
283 :    
284 :     sub _call_method {
285 :     # Get the parameters.
286 :     my ($self, $method, $args) = @_;
287 :     # Declare the return variable.
288 :     my $retVal;
289 :     # Get our user agent.
290 :     my $ua = $self->{ua};
291 :     # Determine the type.
292 :     if (ref $ua eq 'LWP::UserAgent') {
293 :     # Here we're going to a server. Compute the argument document.
294 :     my $argString = YAML::Dump($args);
295 :     # Request the function from the server.
296 :     my $content = $self->_send_request(function => $method, args => $argString,
297 :     source => __PACKAGE__);
298 :     $retVal = YAML::Load($content);
299 :     } else {
300 :     # Here we're calling a local method.
301 :     $retVal = eval("\$ua->$method(\$args)");
302 :     # Check for an error.
303 :     if ($@) {
304 :     die "Package error: $@";
305 :     }
306 :     }
307 :     # Return the result.
308 :     return $retVal;
309 :     }
310 :    
311 :     =head3 _send_file
312 :    
313 :     my $name = $server->_send_file($ih);
314 :    
315 :     Send a file of data to the server and return its name.
316 :    
317 :     =over 4
318 :    
319 :     =item ih
320 :    
321 :     Open input file handle or the name of the input file.
322 :    
323 :     =item RETURN
324 :    
325 :     Returns the name of the file created on the server. This is not the full name
326 :     of the file; rather, it is enough information for the server to find the file
327 :     again when it needs it.
328 :    
329 :     =back
330 :    
331 :     =cut
332 :    
333 :     sub _send_file {
334 :     # Get the parameters.
335 :     my ($self, $ih) = @_;
336 :     # Declare the return variable.
337 :     my $retVal;
338 :     # Get the user agent.
339 :     my $ua = $self->{ua};
340 :     # Find out if we have a handle or a file name. When we're done, we'll have an
341 :     # open handle to the file in $ih_real.
342 :     my $ih_real;
343 :     if (ref $ih eq 'GLOB') {
344 :     $ih_real = $ih;
345 :     } else {
346 :     open $ih_real, "<$ih" || die "File error: $!";
347 :     }
348 :     # Are we in localhost mode?
349 :     if (ref $ua eq 'LWP::UserAgent') {
350 :     # Tell the server to create the file and get the file name back.
351 :     $retVal = $self->_send_request(file => 'create');
352 :     # Loop through the input, reading and sending chunks of data.
353 :     my ($chunk, $rc);
354 :     while (! eof $ih) {
355 :     # Get a chunk of data.
356 :     my $rc = read $ih, $chunk, CHUNKSIZE;
357 :     # Check for errors.
358 :     if (! defined $rc) {
359 :     die "File error: $!";
360 :     } elsif ($rc > 0) {
361 :     # Here we have data to send.
362 :     $self->_send_request(file => 'write', name => $retVal, data => $chunk);
363 :     }
364 :     }
365 :     } else {
366 :     # Here we're in local mode. We need a copy of the file in the FIG temporary
367 :     # directory.
368 :     require File::Temp;
369 :     require FIG_Config;
370 :     my ($oh, $fileName) = File::Temp::tempfile('tempSERVERsendFileXXXXX',
371 :     suffix => 'txt', UNLINK => 1,
372 :     DIR => $FIG_Config::temp);
373 :     # Copy the input file to the output.
374 :     while (! eof $ih) {
375 :     my $line = <$ih_real>;
376 :     print $oh $line;
377 :     }
378 :     close $oh;
379 :     # Return the file name.
380 :     $retVal = $fileName;
381 :     }
382 :     # Return the result.
383 :     return $retVal;
384 :     }
385 :    
386 :     =head3 _receive_file
387 :    
388 :     $server->_receive_file($oh, $name);
389 :    
390 :     Retrieve the named file of data from the server.
391 :    
392 :     =over 4
393 :    
394 :     =item oh
395 :    
396 :     Open file handle to which the data is to be written, or the name of the file to
397 :     contain the data.
398 :    
399 :     =item name
400 :    
401 :     Name of the data file in the FIG temporary directory on the server.
402 :    
403 :     =back
404 :    
405 :     =cut
406 :    
407 :     sub _receive_file {
408 :     # Get the parameters.
409 :     my ($self, $oh, $name) = @_;
410 :     # Get the user agent.
411 :     my $ua = $self->{ua};
412 :     # Find out if we have a handle or a file name. When we're done, we'll have
413 :     # an open handle to the file in $oh_real.
414 :     my $oh_real;
415 :     if (ref $oh eq 'GLOB') {
416 :     $oh_real = $oh;
417 :     } else {
418 :     open $oh_real, ">$oh" || die "File error: $!";
419 :     }
420 :     # Are we in localhost mode?
421 :     if (ref $ua eq 'LWP::UserAgent') {
422 :     # No, we must get this file from the server. Tell the server to get us
423 :     # the length of the file.
424 :     my $length = $self->_send_request(file => 'open', name => $name);
425 :     # Loop through the file, reading chunks.
426 :     my $location = 0;
427 :     while ($location < $length) {
428 :     my $chunk = $self->_send_request(file => 'read', name => $name,
429 :     location => $location, size => CHUNKSIZE);
430 :     print $oh_real $chunk;
431 :     $location += length $chunk;
432 :     }
433 :     } else {
434 :     # Open the named file for input.
435 :     require FIG_Config;
436 :     open my $ih, "<$FIG_Config::temp/$name";
437 :     # Copy it to the output.
438 :     while (! eof $ih) {
439 :     my $line = <$ih>;
440 :     print $oh_real $line;
441 :     }
442 :     }
443 :     # If we opened the output file ourselves, close it.
444 :     if (ref $oh ne 'GLOB') {
445 :     close $oh_real;
446 :     }
447 :     }
448 :    
449 :    
450 :     =head3 _send_request
451 :    
452 :     my $result = $server->_send_request(%parms);
453 :    
454 :     Send a request to the server. This method must not be called in localhost
455 :     mode. If an error occurs, this method will die; otherwise, the content of
456 :     the response will be passed back as the result.
457 :    
458 :     =over 4
459 :    
460 :     =item parms
461 :    
462 :     Hash of CGI parameters to send to the server.
463 :    
464 :     =item RETURN
465 :    
466 :     Returns the string returned by the server in response to the request.
467 :    
468 :     =back
469 :    
470 :     =cut
471 :    
472 :     sub _send_request {
473 :     # Get the parameters.
474 :     my ($self, %parms) = @_;
475 :     # Get the user agent.
476 :     my $ua = $self->{ua};
477 :     # Request the function from the server. Note that the hash is actually passed
478 :     # as a list reference.
479 : olson 1.4 #
480 :     # retries is the set of retry wait times in seconds we should use. when
481 :     # we run out the call will fail.
482 :     #
483 :    
484 :     my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
485 : olson 1.5 my %codes_to_retry = map { $_ => 1 } qw(110 408 502 503 504 200) ;
486 : olson 1.4 my $response;
487 :    
488 :     while (1)
489 :     {
490 :     $response = $ua->post($self->{server_url}, [ %parms ]);
491 :     if ($response->is_success)
492 :     {
493 :     my $retVal = $response->content;
494 :     return $retVal;
495 :     }
496 :    
497 :     #
498 :     # If this is not one of the error codes we retry for, or if we
499 :     # are out of retries, fail immediately
500 :     #
501 :     my $code = $response->code;
502 :     if (!$codes_to_retry{$code} || @retries == 0)
503 :     {
504 : parrello 1.6 if ($ENV{SAS_DEBUG}) {
505 : parrello 1.8 confess $response->content;
506 : parrello 1.6 } else {
507 : parrello 1.9 confess $response->status_line;
508 : parrello 1.6 }
509 : olson 1.4 }
510 :    
511 :     #
512 :     # otherwise, sleep & loop.
513 :     #
514 :     my $retry_time = shift(@retries);
515 :     print STDERR "Request failed with code=$code, sleeping $retry_time and retrying\n";
516 :     sleep($retry_time);
517 :    
518 : parrello 1.1 }
519 : olson 1.4
520 :     #
521 :     # Should never get here.
522 :     #
523 : parrello 1.1 }
524 :    
525 :    
526 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3