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

Annotation of /FigKernelPackages/ClientThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3