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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package ServerThing;
4 : olson 1.76 use Data::Dumper;
5 : parrello 1.1 use strict;
6 :     use Tracer;
7 :     use YAML;
8 : parrello 1.50 use JSON::Any;
9 : parrello 1.1 use ERDB;
10 :     use TestUtils;
11 :     use Time::HiRes;
12 : parrello 1.9 use File::Temp;
13 : parrello 1.10 use ErrorMessage;
14 : parrello 1.1 use CGI;
15 : parrello 1.9 no warnings qw(once);
16 : parrello 1.1
17 : parrello 1.11 # Maximum number of requests to run per invocation.
18 : olson 1.48 use constant MAX_REQUESTS => 50;
19 : parrello 1.11
20 : parrello 1.1 =head1 General Server Helper
21 :    
22 :     This package provides a method-- I<RunServer>-- that can be called from a CGI
23 : parrello 1.9 script to perform the duties of a FIG server. RunServer is called with two
24 :     parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
25 :     the first command-line parameter. The command-line parameter (if defined) will
26 :     be used as the tracing key, and also indicates that the script is being invoked
27 :     from the command line rather than over the web.
28 : parrello 1.1
29 :     =cut
30 :    
31 :     sub RunServer {
32 :     # Get the parameters.
33 : parrello 1.9 my ($serverName, $key) = @_;
34 : parrello 1.25 # Set up tracing. We never do CGI tracing here; the only question is whether
35 :     # or not the caller passed in a tracing key. If he didn't, we use the server
36 :     # name.
37 : parrello 1.32 ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
38 : parrello 1.9 # Turn off YAML compression, which causes problems with some of our hash keys.
39 :     $YAML::CompressSeries = 0;
40 : parrello 1.13 # Create the server object.
41 : parrello 1.15 Trace("Requiring $serverName for task $$.") if T(3);
42 : parrello 1.13 eval {
43 : chenry 1.60 my $output = $serverName;
44 : devoid 1.74 $output =~ s/::/\//g;
45 : dejongh 1.61 require "$output.pm";
46 : parrello 1.13 };
47 :     # If we have an error, create an error document.
48 :     if ($@) {
49 :     SendError($@, "Could not load server module.");
50 :     } else {
51 :     # Having successfully loaded the server code, we create the object.
52 :     my $serverThing = eval("$serverName" . '->new()');
53 : parrello 1.15 Trace("$serverName object created for task $$.") if T(2);
54 : parrello 1.13 # If we have an error, create an error document.
55 :     if ($@) {
56 :     SendError($@, "Could not start server.");
57 : parrello 1.3 } else {
58 : devoid 1.75 # No error, so now we can process the request. First, get the method list.
59 :     my $methods = $serverThing->methods();
60 :     # Store it in the object so we can use it to validate methods.
61 :     my %methodHash = map { $_ => 1 } @$methods;
62 :     $serverThing->{methods} = \%methodHash;
63 : parrello 1.13 my $cgi;
64 :     if (! defined $key) {
65 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
66 :     if ($ENV{REQUEST_METHOD} eq '') {
67 :     # Count the number of requests.
68 :     my $requests = 0;
69 : devoid 1.75 # warn "Starting fast CGI loop.\n"; ##HACK Trace("Starting Fast CGI loop.") if T(3);
70 : parrello 1.13 # Loop through the fast CGI requests. If we have request throttling,
71 :     # we exit after a maximum number of requests has been exceeded.
72 :     require CGI::Fast;
73 : devoid 1.75 open(SERVER_STDERR, ">&", *STDERR);
74 : parrello 1.23 while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
75 :     ($cgi = new CGI::Fast())) {
76 : devoid 1.75 #
77 :     # Remap STDERR. Inside here, our STDERR is a tie to a FCGI::Stream
78 :     # so we need to save it to keep FCGI happy.
79 :     #
80 :     *SAVED_STDERR = *STDERR;
81 :     *STDERR = *SERVER_STDERR;
82 :     my $function = $cgi->param('function') || "<non-functional>"; # (useful if we do tracing in here)
83 :     # warn "Function request is $function in task $$.\n"; ##HACK
84 : parrello 1.13 RunRequest($cgi, $serverThing);
85 : devoid 1.75 # warn "$requests requests complete in fast CGI task $$.\n"; ##HACK Trace("Request $requests complete in task $$.") if T(3);
86 :     *STDERR = *SAVED_STDERR;
87 : parrello 1.13 }
88 : devoid 1.75 # warn "Terminating FastCGI task $$ after $requests requests.\n"; ##HACK Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
89 :     close(SERVER_STDERR);
90 : parrello 1.13 } else {
91 :     # Here we have a normal web service (non-Fast).
92 :     my $cgi = CGI->new();
93 :     # Check for a source parameter. This gets used as the tracing key.
94 :     $key = $cgi->param('source');
95 :     # Run this request.
96 :     RunRequest($cgi, $serverThing);
97 :     }
98 : parrello 1.6 } else {
99 : parrello 1.13 # We're being invoked from the command line. Use the tracing
100 :     # key to find the parm file and create the CGI object from that.
101 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
102 :     $cgi = CGI->new($ih);
103 :     # Run this request.
104 :     RunRequest($cgi, $serverThing);
105 : parrello 1.6 }
106 : parrello 1.3 }
107 : parrello 1.1 }
108 : parrello 1.6 }
109 :    
110 : olson 1.76 =head2 RunRabbitMQClient
111 :    
112 :     This routine sets itself up as a FCGI listener for incoming FCGI requests (like
113 :     RunServer), but instead of processing the requests forwards them to the
114 :     RabbitMQ message broker. For each request, we set up an ephemeral response
115 :     queue for handling the response to the message.
116 :    
117 :     Note that we don't touch the message bodies; they are only decoded on the
118 :     actual messaging processing node.
119 :    
120 :    
121 :     =cut
122 :    
123 :     sub RunRabbitMQClient {
124 :     # Get the parameters.
125 :     my ($serverName, $conf) = @_;
126 :    
127 :     require Net::RabbitMQ;
128 :     require UUID;
129 :     require CGI::Fast;
130 :    
131 :     my $conn = Net::RabbitMQ->new();
132 :    
133 :     $conn->connect($conf->{rabbitmq_host},
134 :     { user => $conf->{rabbitmq_user}, password => $conf->{rabbitmq_password} });
135 :    
136 :     my $channel = 1;
137 :     $conn->channel_open($channel);
138 :    
139 :     my $exchange_name = "svr.$serverName";
140 :    
141 :     my $queue_name = $conn->queue_declare($channel,'', { durable => 0, exclusive => 1, auto_delete => 1 });
142 :     print "Created $queue_name\n";
143 :    
144 :     my $requests = 0;
145 :     open(SERVER_STDERR, ">&", *STDERR);
146 :     while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
147 :     (my $cgi = new CGI::Fast())) {
148 :     #
149 :     # Remap STDERR. Inside here, our STDERR is a tie to a FCGI::Stream
150 :     # so we need to save it to keep FCGI happy.
151 :     #
152 :     *SAVED_STDERR = *STDERR;
153 :     *STDERR = *SERVER_STDERR;
154 :    
155 :     print STDERR "Working...\n";
156 :    
157 :     my $function = $cgi->param('function');
158 :    
159 :     my($uuid, $uuid_str);
160 :    
161 :     UUID::generate($uuid);
162 :     UUID::unparse($uuid, $uuid_str);
163 :    
164 :     my $encoding = $cgi->param('encoding') || 'yaml';
165 :     my $type = $encoding eq 'yaml' ? 'application/yaml' : 'application/json';
166 :    
167 :     print STDERR "publish request to $exchange_name rpc.$function\n";
168 :     $conn->publish($channel, "rpc.$function", $cgi->param('args'),
169 :     { exchange => $exchange_name },
170 :     {
171 :     content_type => $type,
172 :     correlation_id => $uuid_str,
173 :     reply_to => $queue_name,
174 :     });
175 :    
176 :     print STDERR "await resp\n";
177 :     $conn->consume($channel, $queue_name, { no_ack => 1 });
178 :    
179 :     my $msg = $conn->recv();
180 :     print STDERR Dumper($msg);
181 :     print "OK\n";
182 :    
183 :     *STDERR = *SAVED_STDERR;
184 :     }
185 :     # warn "Terminating FastCGI task $$ after $requests requests.\n"; ##HACK Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
186 :     close(SERVER_STDERR);
187 :    
188 :     }
189 :    
190 :     sub RunRabbitMQClientAsync {
191 :     # Get the parameters.
192 :     my ($serverName, $conf) = @_;
193 :    
194 :     require Net::Async::FastCGI;
195 :     require IO::Handle;
196 :     require IO::Async::Loop;
197 :     require IO::Async::Handle;
198 :     require IO::Async::Timer::Periodic;
199 :     require Net::RabbitMQ;
200 :     require UUID;
201 :     require CGI::Fast;
202 :    
203 :     my $loop = IO::Async::Loop->new();
204 :    
205 :     my $conn = Net::RabbitMQ->new();
206 :    
207 :     my $rabbit_fd = $conn->connect($conf->{rabbitmq_host},
208 :     { user => $conf->{rabbitmq_user}, password => $conf->{rabbitmq_password} });
209 :    
210 :     my $channel = 1;
211 :     $conn->channel_open($channel);
212 :    
213 :     my $exchange_name = "svr.$serverName";
214 :    
215 :     my $queue_name = $conn->queue_declare($channel,'', { durable => 0, exclusive => 1, auto_delete => 1 });
216 :     print "Created $queue_name $conf->{fcgi_port}\n";
217 :    
218 :     $conn->consume($channel, $queue_name, { no_ack => 1 });
219 :    
220 :     my $waiting = {};
221 :     my $global = { messages => 0 };
222 :     my $rabbit_fh = IO::Handle->new();
223 :     $rabbit_fh->fdopen($rabbit_fd, "r");
224 :    
225 :     my $timer = IO::Async::Timer::Periodic->new(interval => 10,
226 :     on_tick => sub {
227 :     my $last = $global->{last_time};
228 :     my $now = time;
229 :     if (defined($last))
230 :     {
231 :     my $int = $now - $last;
232 :     my $rate = $global->{messages} / $int;
233 :     print "$rate\n";
234 :     }
235 :     $global->{last_time} = $now;
236 :     $global->{messages} = 0;
237 :     });
238 :     $timer->start();
239 :     $loop->add($timer);
240 :     my $rabbit_listener = IO::Async::Handle->new(read_handle => $rabbit_fh,
241 :     on_read_ready => sub {
242 :     AsyncRabbitCheck($loop, $channel, $conn,
243 :     $exchange_name, $queue_name,
244 :     $waiting);
245 :     });
246 :     $loop->add($rabbit_listener);
247 :    
248 :     my $fcgi = Net::Async::FastCGI->new(on_request => sub {
249 :     my($fcgi, $req) = @_;
250 :     $global->{messages}++;
251 :     AsyncFcgiReq($loop, $fcgi, $req, $channel, $conn, $queue_name,
252 :     $exchange_name, $waiting);
253 :     });
254 :     $loop->add( $fcgi );
255 :    
256 :     $fcgi->listen(service => $conf->{fcgi_port},
257 :     socktype => 'stream',
258 :     host => '0.0.0.0',
259 :     on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; },
260 :     on_listen_error => sub { print STDERR "Cannot listen\n"; },
261 :     );
262 :    
263 :     $loop->loop_forever();
264 :     }
265 :    
266 :     sub AsyncRabbitCheck
267 :     {
268 :     my($loop, $channel, $conn, $exchange_name, $queue_name, $waiting) = @_;
269 :     # print "Rabbit check!\n";
270 :     my $msg = $conn->recv();
271 :    
272 :     my $corr= $msg->{props}->{correlation_id};
273 :    
274 :     my $slot = delete $waiting->{$corr};
275 :     if ($slot)
276 :     {
277 :     # print "Finish request\n";
278 :     my $req = $slot->{request};
279 :    
280 :     eval {
281 :     $req->print_stdout("Status: 200 OK\r\n" .
282 :     "Content-type: application/octet-stream\r\n" .
283 :     "\r\n");
284 :     $req->print_stdout($msg->{body});
285 :     $req->finish();
286 :     };
287 :     }
288 :     else
289 :     {
290 :     print "No match for $corr\n";
291 :     }
292 :     }
293 :    
294 :     sub AsyncFcgiReq
295 :     {
296 :     my($loop, $fcgi, $req, $channel, $conn, $queue_name, $exchange_name, $waiting) = @_;
297 :    
298 :     # print STDERR "Working...\n";
299 :    
300 :     my $params = $req->params;
301 :     my $cgi = CGI->new();
302 :     my $in = $req->read_stdin;
303 :     $cgi->parse_params($in);
304 :    
305 :     my $function = $cgi->param('function');
306 :    
307 :     my($uuid, $uuid_str);
308 :    
309 :     UUID::generate($uuid);
310 :     UUID::unparse($uuid, $uuid_str);
311 :    
312 :     my $encoding = $cgi->param('encoding') || 'yaml';
313 :     my $type = $encoding eq 'yaml' ? 'application/yaml' : 'application/json';
314 :    
315 :     # print STDERR "publish request to $exchange_name rpc.$function\n";
316 :     $conn->publish($channel, "rpc.$function", $cgi->param('args'),
317 :     { exchange => $exchange_name },
318 :     {
319 :     content_type => $type,
320 :     correlation_id => $uuid_str,
321 :     reply_to => $queue_name,
322 :     });
323 :    
324 :     # print STDERR "await resp\n";
325 :    
326 :     $waiting->{$uuid_str} = { request => $req };
327 :     }
328 :    
329 :     =head2 RunRabbitMQServer
330 :    
331 :     This is the agent code that listens on a queue for incoming requests to
332 :     process data. We run one of these processes for every core we want to
333 :     do active processing.
334 :    
335 :     =cut
336 :    
337 :     sub RunRabbitMQServer {
338 :     # Get the parameters.
339 :     my ($serverName, $conf) = @_;
340 :    
341 :     eval {
342 :     my $output = $serverName;
343 :     $output =~ s/::/\//;
344 :     require "$output.pm";
345 :     };
346 :    
347 :     if ($@) {
348 :     die "Could not load server module $serverName";
349 :     }
350 :     # Having successfully loaded the server code, we create the object.
351 :     my $serverThing = $serverName->new();
352 :    
353 :     require Net::RabbitMQ;
354 :     require UUID;
355 :     require CGI::Fast;
356 :    
357 :     my $conn = Net::RabbitMQ->new();
358 :    
359 :     $conn->connect($conf->{rabbitmq_host},
360 :     { user => $conf->{rabbitmq_user}, password => $conf->{rabbitmq_password} });
361 :    
362 :     my $channel = 1;
363 :     $conn->channel_open($channel);
364 :    
365 :     $conn->basic_qos($channel, { prefetch_count => 1 });
366 :    
367 :     my $exchange_name = "svr.$serverName";
368 :    
369 :     my $queue_name = "q.$exchange_name";
370 :    
371 :     # $conn->queue_unbind($channel, $queue_name, $exchange_name, 'rpc.*');
372 :     # $conn->queue_unbind($channel, $queue_name, $exchange_name, 'rpc.#');
373 :     # $conn->exchange_delete($channel, $exchange_name);
374 :    
375 :     $conn->exchange_declare($channel, $exchange_name, { exchange_type => "topic", durable => 1,
376 :     auto_delete => 0 });
377 :    
378 :     $conn->queue_declare($channel, $queue_name, { durable => 1, exclusive => 0, auto_delete => 0 });
379 :    
380 :     $conn->queue_bind($channel, $queue_name, $exchange_name, 'rpc.*');
381 :    
382 :     $conn->consume($channel, $queue_name, { no_ack => 0 } );
383 :     while (1)
384 :     {
385 :     #print STDERR "Await message\n";
386 :    
387 :     my $msg = $conn->recv();
388 :    
389 :     my $key = $msg->{routing_key};
390 :    
391 :     my $args = [];
392 :    
393 :     my $method;
394 :     my $encoding;
395 :     my $reply_to;
396 :     my $corr;
397 :     if ($key =~ /^rpc.(.*)/)
398 :     {
399 :     $method = $1;
400 :    
401 :     my $props = $msg->{props};
402 :     $encoding = $props->{content_type};
403 :     $corr = $props->{correlation_id};
404 :     $reply_to = $props->{reply_to};
405 :    
406 :     my $body = $msg->{body};
407 :    
408 :     eval {
409 :     if ($encoding eq 'application/json')
410 :     {
411 :     $args = JSON::Any->jsonToObj($body);
412 :     }
413 :     elsif ($encoding eq 'application/yaml')
414 :     {
415 :     $args = YAML::Load($body);
416 :     }
417 :     else
418 :     {
419 :     warn "Invalid encoding $encoding";
420 :     $args = [];
421 :     }
422 :     };
423 :     }
424 :     else
425 :     {
426 :     die "invalid method key\n";
427 :     }
428 :    
429 :     #print "$method $corr\n";
430 :     print "$$ $method\n";
431 :    
432 :     my $res = eval { $serverThing->$method($args) };
433 :    
434 :     my $enc_res = '';
435 :     eval {
436 :     if ($encoding eq 'application/json')
437 :     {
438 :     $enc_res = JSON::Any->objToJson($res);
439 :     }
440 :     elsif ($encoding eq 'application/yaml')
441 :     {
442 :     $enc_res = YAML::Dump($res);
443 :     }
444 :     };
445 :    
446 :     $conn->ack($channel, $msg->{delivery_tag});
447 :     $conn->publish($channel, $reply_to, $enc_res, { exchange => '' }, { correlation_id => $corr });
448 :    
449 :     }
450 :     }
451 :    
452 : parrello 1.6
453 : parrello 1.9 =head2 Server Utility Methods
454 :    
455 :     The methods in this section are utilities of general use to the various
456 :     server modules.
457 :    
458 : parrello 1.21 =head3 AddSubsystemFilter
459 :    
460 : parrello 1.52 ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
461 : parrello 1.21
462 :     Add subsystem filtering information to the specified query filter clause
463 :     based on data in the argument hash. The argument hash will be checked for
464 : parrello 1.52 the C<-usable> parameter, which includes or excludes unusuable subsystems,
465 : parrello 1.22 the C<-exclude> parameter, which lists types of subsystems that should be
466 : parrello 1.52 excluded, and the C<-aux> parameter, which filters on auxiliary roles.
467 : parrello 1.21
468 :     =over 4
469 :    
470 :     =item filter
471 :    
472 :     Reference to the current filter string. If additional filtering is required,
473 :     this string will be updated.
474 :    
475 :     =item args
476 :    
477 :     Reference to the parameter hash for the current server call. This hash will
478 : parrello 1.22 be examined for the C<-usable> and C<-exclude> parameters.
479 : parrello 1.21
480 : parrello 1.52 =item roles
481 :    
482 :     If TRUE, role filtering will be applied. In this case, the default action
483 :     is to exclude auxiliary roles unless C<-aux> is TRUE.
484 :    
485 : parrello 1.21 =back
486 :    
487 :     =cut
488 :    
489 :     use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
490 :     experimental => 1,
491 :     private => 1 };
492 :    
493 :     sub AddSubsystemFilter {
494 :     # Get the parameters.
495 : parrello 1.52 my ($filter, $args, $roles) = @_;
496 : parrello 1.21 # We'll put the new filter stuff in here.
497 :     my @newFilters;
498 :     # Unless unusable subsystems are desired, we must add a clause to the filter.
499 : parrello 1.22 # The default is that only usable subsystems are included.
500 :     my $usable = 1;
501 :     # This default can be overridden by the "-usable" parameter.
502 :     if (exists $args->{-usable}) {
503 :     $usable = $args->{-usable};
504 :     }
505 :     # If we're restricting to usable subsystems, add a filter to that effect.
506 :     if ($usable) {
507 : parrello 1.21 push @newFilters, "Subsystem(usable) = 1";
508 :     }
509 :     # Check for exclusion filters.
510 :     my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
511 :     for my $exclusion (@$exclusions) {
512 :     if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
513 :     Confess("Invalid exclusion type \"$exclusion\".");
514 :     } else {
515 :     # Here we have to exclude subsystems of the specified type.
516 :     push @newFilters, "Subsystem($exclusion) = 0";
517 :     }
518 :     }
519 : parrello 1.52 # Check for role filtering.
520 :     if ($roles) {
521 :     # Here, we filter out auxiliary roles unless the user requests
522 :     # them.
523 :     if (! $args->{-aux}) {
524 :     push @newFilters, "Includes(auxiliary) = 0"
525 :     }
526 :     }
527 : parrello 1.21 # Do we need to update the incoming filter?
528 :     if (@newFilters) {
529 :     # Yes. If the incoming filter is nonempty, push it onto the list
530 :     # so it gets included in the result.
531 :     if ($$filter) {
532 :     push @newFilters, $$filter;
533 :     }
534 :     # Put all the filters together to form the new filter.
535 :     $$filter = join(" AND ", @newFilters);
536 : parrello 1.26 Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
537 : parrello 1.21 }
538 :     }
539 :    
540 :    
541 :    
542 : parrello 1.9 =head3 GetIdList
543 :    
544 : parrello 1.19 my $ids = ServerThing::GetIdList($name => $args, $optional);
545 : parrello 1.9
546 :     Get a named list of IDs from an argument structure. If the IDs are
547 :     missing, or are not a list, an error will occur.
548 :    
549 :     =over 4
550 :    
551 :     =item name
552 :    
553 :     Name of the argument structure member that should contain the ID list.
554 :    
555 :     =item args
556 :    
557 :     Argument structure from which the ID list is to be extracted.
558 :    
559 : parrello 1.19 =item optional (optional)
560 :    
561 :     If TRUE, then a missing value will not generate an error. Instead, an empty list
562 :     will be returned. The default is FALSE.
563 :    
564 : parrello 1.9 =item RETURN
565 :    
566 :     Returns a reference to a list of IDs taken from the argument structure.
567 :    
568 :     =back
569 :    
570 :     =cut
571 :    
572 :     sub GetIdList {
573 :     # Get the parameters.
574 : parrello 1.19 my ($name, $args, $optional) = @_;
575 : parrello 1.35 # Declare the return variable.
576 :     my $retVal;
577 : parrello 1.32 # Check the argument format.
578 : parrello 1.35 if (! defined $args && $optional) {
579 :     # Here there are no parameters, but the arguments are optional so it's
580 :     # okay.
581 :     $retVal = [];
582 :     } elsif (ref $args ne 'HASH') {
583 :     # Here we have an invalid parameter structure.
584 : parrello 1.32 Confess("No '$name' parameter present.");
585 : parrello 1.35 } else {
586 :     # Here we have a hash with potential parameters in it. Try to get the
587 :     # IDs from the argument structure.
588 :     $retVal = $args->{$name};
589 :     # Was a member found?
590 :     if (! defined $retVal) {
591 :     # No. If we're optional, return an empty list; otherwise throw an error.
592 :     if ($optional) {
593 :     $retVal = [];
594 :     } else {
595 :     Confess("No '$name' parameter found.");
596 :     }
597 : parrello 1.19 } else {
598 : parrello 1.35 # Here we found something. Get the parameter type. We want a list reference.
599 :     # If it's a scalar, we'll convert it to a singleton list. If it's anything
600 :     # else, it's an error.
601 :     my $type = ref $retVal;
602 :     if (! $type) {
603 :     $retVal = [$retVal];
604 :     } elsif ($type ne 'ARRAY') {
605 :     Confess("The '$name' parameter must be a list.");
606 :     }
607 : parrello 1.19 }
608 : parrello 1.9 }
609 :     # Return the result.
610 :     return $retVal;
611 :     }
612 :    
613 :    
614 :     =head3 RunTool
615 :    
616 :     ServerThing::RunTool($name => $cmd);
617 :    
618 :     Run a command-line tool. A non-zero return value from the tool will cause
619 :     a fatal error, and the tool's error log will be traced.
620 :    
621 :     =over 4
622 :    
623 :     =item name
624 :    
625 :     Name to give to the tool in the error output.
626 :    
627 :     =item cmd
628 :    
629 :     Command to use for running the tool. This should be the complete command line.
630 :     The command should not contain any fancy piping, though it may redirect the
631 :     standard input and output. The command will be modified by this method to
632 :     redirect the error output to a temporary file.
633 :    
634 :     =back
635 :    
636 :     =cut
637 :    
638 :     sub RunTool {
639 :     # Get the parameters.
640 :     my ($name, $cmd) = @_;
641 :     # Compute the log file name.
642 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
643 :     # Execute the command.
644 : parrello 1.26 Trace("Executing command: $cmd") if T(ServerUtilities => 3);
645 : parrello 1.9 my $res = system("$cmd 2> $errorLog");
646 : parrello 1.26 Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
647 : parrello 1.9 # Check the result code.
648 :     if ($res != 0) {
649 :     # We have an error. If tracing is on, trace it.
650 : parrello 1.26 if (T(ServerUtilities => 1)) {
651 : parrello 1.9 TraceErrorLog($name, $errorLog);
652 :     }
653 :     # Delete the error log.
654 :     unlink $errorLog;
655 :     # Confess the error.
656 : parrello 1.10 Confess("$name command failed with error code $res.");
657 : parrello 1.9 } else {
658 :     # Everything worked. Trace the error log if necessary.
659 : parrello 1.26 if (T(ServerUtilities => 3) && -s $errorLog) {
660 : parrello 1.9 TraceErrorLog($name, $errorLog);
661 :     }
662 :     # Delete the error log if there is one.
663 :     unlink $errorLog;
664 :     }
665 :     }
666 :    
667 : parrello 1.56 =head3 ReadCountVector
668 :    
669 :     my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
670 :    
671 :     Extract a count vector from a query. The query can contain zero or more results,
672 :     and the vectors in the specified result field of the query must be concatenated
673 :     together in order. This method is optimized for the case (expected to be most
674 :     common) where there is only one result.
675 :    
676 :     =over 4
677 :    
678 :     =item qh
679 :    
680 :     Handle for the query from which results are to be extracted.
681 :    
682 :     =item field
683 :    
684 :     Name of the field containing the count vectors.
685 :    
686 :     =item rawFlag
687 :    
688 :     TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
689 :     as reference to a list of numbers.
690 :    
691 :     =item RETURN
692 :    
693 :     Returns the desired vector, either encoded as a string or as a reference to a list
694 :     of numbers.
695 :    
696 :     =back
697 :    
698 :     =cut
699 :    
700 :     sub ReadCountVector {
701 :     # Get the parameters.
702 :     my ($qh, $field, $rawFlag) = @_;
703 :     # Declare the return variable.
704 :     my $retVal;
705 :     # Loop through the query results.
706 :     while (my $resultRow = $qh->Fetch()) {
707 :     # Get this vector.
708 :     my ($levelVector) = $resultRow->Value($field, $rawFlag);
709 :     # Is this the first result?
710 :     if (! defined $retVal) {
711 :     # Yes. Assign the result directly.
712 :     $retVal = $levelVector;
713 :     } elsif ($rawFlag) {
714 :     # This is a second result and the vectors are coded as strings.
715 :     $retVal .= $levelVector;
716 :     } else {
717 :     # This is a second result and the vectors are coded as array references.
718 :     push @$retVal, @$levelVector;
719 :     }
720 :     }
721 :     # Return the result.
722 :     return $retVal;
723 :     }
724 :    
725 : parrello 1.58 =head3 ChangeDB
726 :    
727 :     ServerThing::ChangeDB($thing, $newDbName);
728 :    
729 :     Change the sapling database used by this server. The old database will be closed and a
730 :     new one attached.
731 :    
732 :     =over 4
733 :    
734 :     =item newDbName
735 :    
736 :     Name of the new Sapling database on which this server should operate. If omitted, the
737 :     default database will be used.
738 :    
739 :     =back
740 :    
741 :     =cut
742 :    
743 :     sub ChangeDB {
744 :     # Get the parameters.
745 :     my ($thing, $newDbName) = @_;
746 :     # Default the db-name if it's not specified.
747 :     if (! defined $newDbName) {
748 :     $newDbName = $FIG_Config::saplingDB;
749 :     }
750 :     # Check to see if we really need to change.
751 :     my $oldDB = $thing->{db};
752 :     if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
753 :     # We need a new sapling.
754 :     require Sapling;
755 :     my $newDB = Sapling->new(dbName => $newDbName);
756 :     $thing->{db} = $newDB;
757 :     }
758 :     }
759 :    
760 : parrello 1.36
761 : parrello 1.37 =head2 Gene Correspondence File Methods
762 : parrello 1.36
763 : parrello 1.37 These methods relate to gene correspondence files, which are generated by the
764 :     L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
765 :     organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
766 :     copied into the organism directories themselves. At that point, the code below
767 :     will be modified to check the organism directories first and use the cache
768 :     directory if no file is found there.
769 :    
770 :     A gene correspondence file contains correspondences from a source genome to a
771 :     target genome. Most such correspondences are bidirectional best hits. A unidirectional
772 :     best hit may exist from the source genome to the target genome or in the reverse
773 :     direction from the targtet genome to the source genome. The cache directory itself
774 :     is divided into subdirectories by organism. The subdirectory has the source genome
775 :     name and the files themselves are named by the target genome.
776 :    
777 :     Some of the files are invalid and will be erased when they are found. A file is
778 :     considered invalid if it has a non-numeric value in a numeric column or if it
779 :     does not have any unidirectional hits from the target genome to the source
780 :     genome.
781 :    
782 :     The process of managing the correspondence files is tricky and dangerous because
783 :     of the possibility of race conditions. It can take several minutes to generate a
784 :     file, and if two processes try to generate the same file at the same time we need
785 :     to make sure they don't step on each other.
786 :    
787 :     In stored files, the source genome ID is always lexically lower than the target
788 :     genome ID. If a correspondence in the reverse direction is desired, the converse
789 :     file is found and the contents flipped automatically as they are read. So, the
790 :     correspondence from B<360108.3> to B<100226.1> would be found in a file with the
791 :     name B<360108.3> in the directory for B<100226.1>. Since this file actually has
792 :     B<100226.1> as the source and B<360108.3> as the target, the columns are
793 :     re-ordered and the arrows reversed before the file contents are passed to the
794 :     caller.
795 :    
796 :     =head4 Gene Correspondence List
797 :    
798 :     A gene correspondence file contains 18 columns. These are usually packaged as
799 :     a reference to list of lists. Each sub-list has the following format.
800 :    
801 :     =over 4
802 :    
803 :     =item 0
804 :    
805 :     The ID of a PEG in genome 1.
806 :    
807 :     =item 1
808 :    
809 :     The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
810 :    
811 :     =item 2
812 :    
813 :     Count of the number of pairs of matching genes were found in the context.
814 :    
815 :     =item 3
816 :    
817 :     Pairs of corresponding genes from the contexts.
818 :    
819 :     =item 4
820 :    
821 :     The function of the gene in genome 1.
822 :    
823 :     =item 5
824 :    
825 :     The function of the gene in genome 2.
826 :    
827 :     =item 6
828 :    
829 :     Comma-separated list of aliases for the gene in genome 1 (any protein with an
830 :     identical sequence is considered an alias, whether or not it is actually the
831 :     name of the same gene in the same genome).
832 :    
833 :     =item 7
834 :    
835 :     Comma-separated list of aliases for the gene in genome 2 (any protein with an
836 :     identical sequence is considered an alias, whether or not it is actually the
837 :     name of the same gene in the same genome).
838 :    
839 :     =item 8
840 :    
841 :     Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
842 :    
843 :     =item 9
844 :    
845 :     Percent identity over the region of the detected match.
846 :    
847 :     =item 10
848 :    
849 :     The P-score for the detected match.
850 :    
851 :     =item 11
852 :    
853 :     Beginning match coordinate in the protein encoded by the gene in genome 1.
854 :    
855 :     =item 12
856 :    
857 :     Ending match coordinate in the protein encoded by the gene in genome 1.
858 :    
859 :     =item 13
860 :    
861 :     Length of the protein encoded by the gene in genome 1.
862 :    
863 :     =item 14
864 :    
865 :     Beginning match coordinate in the protein encoded by the gene in genome 2.
866 :    
867 :     =item 15
868 :    
869 :     Ending match coordinate in the protein encoded by the gene in genome 2.
870 :    
871 :     =item 16
872 :    
873 :     Length of the protein encoded by the gene in genome 2.
874 :    
875 :     =item 17
876 :    
877 :     Bit score for the match. Divide by the length of the longer PEG to get
878 :     what we often refer to as a "normalized bit score".
879 :    
880 : devoid 1.75 =item 18 (optional)
881 :    
882 :     Clear-correspondence indicator. If present, will be C<1> if the correspondence is a
883 :     clear bidirectional best hit (no similar candidates) and C<0> otherwise.
884 :    
885 : parrello 1.37 =back
886 :    
887 :     In the actual files, there will also be reverse correspondences indicated by a
888 :     back-arrow ("<-") in item (8). The output returned by the servers, however,
889 :     is filtered so that only forward correspondences occur. If a converse file
890 :     is used, the columns are re-ordered and the arrows reversed so that it looks
891 :     correct.
892 :    
893 :     =cut
894 :    
895 :     # hash for reversing the arrows
896 :     use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
897 :     # list of columns that contain numeric values that need to be validated
898 :     use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
899 :    
900 :     =head3 CheckForGeneCorrespondenceFile
901 :    
902 :     my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
903 :    
904 :     Try to find a gene correspondence file for the specified genome pairing. If the
905 :     file exists, its name and an indication of whether or not it is in the correct
906 :     direction will be returned.
907 : parrello 1.36
908 :     =over 4
909 :    
910 :     =item genome1
911 :    
912 : parrello 1.37 Source genome for the desired correspondence.
913 : parrello 1.36
914 :     =item genome2
915 :    
916 : parrello 1.37 Target genome for the desired correspondence.
917 : parrello 1.36
918 :     =item RETURN
919 :    
920 : parrello 1.37 Returns a two-element list. The first element is the name of the file containing the
921 :     correspondence, or C<undef> if the file does not exist. The second element is TRUE
922 :     if the correspondence would be forward or FALSE if the file needs to be flipped.
923 : parrello 1.36
924 :     =back
925 :    
926 :     =cut
927 :    
928 : parrello 1.37 sub CheckForGeneCorrespondenceFile {
929 : parrello 1.36 # Get the parameters.
930 :     my ($genome1, $genome2) = @_;
931 : parrello 1.37 # Declare the return variables.
932 :     my ($fileName, $converse);
933 :     # Determine the ordering of the genome IDs.
934 :     my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
935 :     $converse = ($genomeA ne $genome1);
936 :     # Look for a file containing the desired correspondence. (The code to check for a
937 :     # pre-computed file in the organism directories is currently turned off, because
938 :     # these files are all currently invalid.)
939 :     my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
940 :     if (0 && -f $testFileName) {
941 : parrello 1.36 # Use the pre-computed file.
942 : parrello 1.44 Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
943 : parrello 1.37 $fileName = $testFileName;
944 :     } elsif (-f $corrFileName) {
945 :     $fileName = $corrFileName;
946 : parrello 1.44 Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
947 : parrello 1.37 }
948 :     # Return the result.
949 :     return ($fileName, $converse);
950 :     }
951 :    
952 :    
953 :     =head3 ComputeCorrespondenceFileName
954 :    
955 :     my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
956 :    
957 :     Compute the name to be given to a genome correspondence file in the organism cache
958 :     and return the source and target genomes that would be in it.
959 :    
960 :     =over 4
961 :    
962 :     =item genome1
963 :    
964 :     Source genome for the desired correspondence.
965 :    
966 :     =item genome2
967 :    
968 :     Target genome for the desired correspondence.
969 :    
970 :     =item RETURN
971 :    
972 :     Returns a three-element list. The first element is the name of the file to contain the
973 :     correspondence, the second element is the name of the genome that would act as the
974 :     source genome in the file, and the third element is the name of the genome that would
975 :     act as the target genome in the file.
976 :    
977 :     =back
978 :    
979 :     =cut
980 :    
981 :     sub ComputeCorrespondenceFileName {
982 :     # Get the parameters.
983 :     my ($genome1, $genome2) = @_;
984 :     # Declare the return variables.
985 :     my ($fileName, $genomeA, $genomeB);
986 :     # Determine the ordering of the genome IDs.
987 : parrello 1.41 if (MustFlipGenomeIDs($genome1, $genome2)) {
988 : parrello 1.43 ($genomeA, $genomeB) = ($genome2, $genome1);
989 :     } else {
990 : parrello 1.37 ($genomeA, $genomeB) = ($genome1, $genome2);
991 :     }
992 :     # Insure the source organism has a subdirectory in the organism cache.
993 : parrello 1.47 my $orgDir = ComputeCorrespondenceDirectory($genomeA);
994 : parrello 1.37 # Compute the name of the correspondence file for the appropriate target genome.
995 :     $fileName = "$orgDir/$genomeB";
996 :     # Return the results.
997 :     return ($fileName, $genomeA, $genomeB);
998 :     }
999 :    
1000 :    
1001 : parrello 1.47 =head3 ComputeCorresopndenceDirectory
1002 :    
1003 :     my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
1004 :    
1005 :     Return the name of the directory that would contain the correspondence files
1006 :     for the specified genome.
1007 :    
1008 :     =over 4
1009 :    
1010 :     =item genome
1011 :    
1012 :     ID of the genome whose correspondence file directory is desired.
1013 :    
1014 :     =item RETURN
1015 :    
1016 :     Returns the name of the directory of interest.
1017 :    
1018 :     =back
1019 :    
1020 :     =cut
1021 :    
1022 :     sub ComputeCorrespondenceDirectory {
1023 :     # Get the parameters.
1024 :     my ($genome) = @_;
1025 :     # Insure the source organism has a subdirectory in the organism cache.
1026 :     my $retVal = "$FIG_Config::orgCache/$genome";
1027 :     Tracer::Insure($retVal, 0777);
1028 :     # Return it.
1029 :     return $retVal;
1030 :     }
1031 :    
1032 :    
1033 : parrello 1.37 =head3 CreateGeneCorrespondenceFile
1034 :    
1035 :     my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1036 :    
1037 :     Create a new gene correspondence file in the organism cache for the specified
1038 :     genome correspondence. The name of the new file will be returned along with
1039 :     an indicator of whether or not it is in the correct direction.
1040 :    
1041 :     =over 4
1042 :    
1043 :     =item genome1
1044 :    
1045 :     Source genome for the desired correspondence.
1046 :    
1047 :     =item genome2
1048 :    
1049 :     Target genome for the desired correspondence.
1050 :    
1051 :     =item RETURN
1052 :    
1053 :     Returns a two-element list. The first element is the name of the file containing the
1054 :     correspondence, or C<undef> if an error occurred. The second element is TRUE
1055 :     if the correspondence would be forward or FALSE if the file needs to be flipped.
1056 :    
1057 :     =back
1058 :    
1059 :     =cut
1060 :    
1061 :     sub CreateGeneCorrespondenceFile {
1062 :     # Get the parameters.
1063 :     my ($genome1, $genome2) = @_;
1064 :     # Declare the return variables.
1065 :     my ($fileName, $converse);
1066 :     # Compute the ultimate name for the correspondence file.
1067 :     my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
1068 :     $converse = ($genome1 ne $genomeA);
1069 :     # Generate a temporary file name in the same directory. We'll build the temporary
1070 :     # file and then rename it when we're done.
1071 :     my $tempFileName = "$corrFileName.$$.tmp";
1072 :     # This will be set to FALSE if we detect an error.
1073 :     my $fileOK = 1;
1074 :     # The file handles will be put in here.
1075 :     my ($ih, $oh);
1076 :     # Protect from errors.
1077 :     eval {
1078 :     # Open the temporary file for output.
1079 :     $oh = Open(undef, ">$tempFileName");
1080 :     # Open a pipe to get the correspondence data.
1081 :     $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
1082 :     Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
1083 :     # Copy the pipe date into the temporary file.
1084 :     while (! eof $ih) {
1085 :     my $line = <$ih>;
1086 :     print $oh $line;
1087 :     }
1088 :     # Close both files. If the close fails we need to know: it means there was a pipe
1089 :     # error.
1090 :     $fileOK &&= close $ih;
1091 :     $fileOK &&= close $oh;
1092 :     };
1093 :     if ($@) {
1094 :     # Here a fatal error of some sort occurred. We need to force the files closed.
1095 :     close $ih if $ih;
1096 :     close $oh if $oh;
1097 :     } elsif ($fileOK) {
1098 :     # Here everything worked. Try to rename the temporary file to the real
1099 :     # file name.
1100 :     if (rename $tempFileName, $corrFileName) {
1101 :     # Everything is ok, fix the permissions and return the file name.
1102 :     chmod 0664, $corrFileName;
1103 :     $fileName = $corrFileName;
1104 : parrello 1.44 Trace("Created correspondence file $fileName.") if T(Corr => 3);
1105 : parrello 1.37 }
1106 :     }
1107 :     # If the temporary file exists, delete it.
1108 :     if (-f $tempFileName) {
1109 :     unlink $tempFileName;
1110 :     }
1111 :     # Return the results.
1112 :     return ($fileName, $converse);
1113 :     }
1114 :    
1115 :    
1116 : parrello 1.41 =head3 MustFlipGenomeIDs
1117 :    
1118 :     my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
1119 :    
1120 :     Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
1121 :     order, they are stored in the converse order in correspondence files on the server.
1122 :     This is a simple method that allows the caller to check for the need to flip.
1123 :    
1124 :     =over 4
1125 :    
1126 :     =item genome1
1127 :    
1128 :     ID of the proposed source genome.
1129 :    
1130 :     =item genome2
1131 :    
1132 :     ID of the proposed target genome.
1133 :    
1134 :     =item RETURN
1135 :    
1136 :     Returns TRUE if the first genome would be stored on the server as a target, FALSE if
1137 :     it would be stored as a source.
1138 :    
1139 : parrello 1.55 =back
1140 :    
1141 : parrello 1.41 =cut
1142 :    
1143 :     sub MustFlipGenomeIDs {
1144 :     # Get the parameters.
1145 :     my ($genome1, $genome2) = @_;
1146 :     # Return an indication.
1147 :     return ($genome1 gt $genome2);
1148 :     }
1149 :    
1150 :    
1151 : parrello 1.37 =head3 ReadGeneCorrespondenceFile
1152 :    
1153 : parrello 1.40 my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
1154 : parrello 1.37
1155 :     Return the contents of the specified gene correspondence file in the form of
1156 :     a list of lists, with backward correspondences filtered out. If the file is
1157 :     for the converse of the desired correspondence, the columns will be reordered
1158 :     automatically so that it looks as if the file were designed for the proper
1159 :     direction.
1160 :    
1161 :     =over 4
1162 :    
1163 :     =item fileName
1164 :    
1165 :     The name of the gene correspondence file to read.
1166 :    
1167 :     =item converse (optional)
1168 :    
1169 :     TRUE if the file is for the converse of the desired correspondence, else FALSE.
1170 :     If TRUE, the file columns will be reorderd automatically. The default is FALSE,
1171 :     meaning we want to use the file as it appears on disk.
1172 :    
1173 : parrello 1.40 =item all (optional)
1174 :    
1175 :     TRUE if backward unidirectional correspondences should be included in the output.
1176 :     The default is FALSE, in which case only forward and bidirectional correspondences
1177 :     are included.
1178 :    
1179 : parrello 1.37 =item RETURN
1180 :    
1181 :     Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
1182 :     If the file's contents are invalid or an error occurs, an undefined value will be
1183 :     returned.
1184 :    
1185 :     =back
1186 :    
1187 :     =cut
1188 :    
1189 :     sub ReadGeneCorrespondenceFile {
1190 :     # Get the parameters.
1191 : parrello 1.40 my ($fileName, $converse, $all) = @_;
1192 : parrello 1.37 # Declare the return variable. We will only put something in here if we are
1193 :     # completely successful.
1194 :     my $retVal;
1195 :     # This value will be set to 1 if an error is detected.
1196 :     my $error = 0;
1197 :     # Try to open the file.
1198 :     my $ih;
1199 :     Trace("Reading correspondence file $fileName.") if T(3);
1200 :     if (! open $ih, "<$fileName") {
1201 :     # Here the open failed, so we have an error.
1202 : parrello 1.44 Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
1203 : parrello 1.37 $error = 1;
1204 :     }
1205 :     # The gene correspondence list will be built in here.
1206 :     my @corrList;
1207 :     # This variable will be set to TRUE if we find a reverse correspondence somewhere
1208 :     # in the file. Not finding one is an error.
1209 :     my $reverseFound = 0;
1210 :     # Loop until we hit the end of the file or an error occurs. We must check the error
1211 :     # first in case the file handle failed to open.
1212 :     while (! $error && ! eof $ih) {
1213 :     # Get the current line.
1214 :     my @row = Tracer::GetLine($ih);
1215 :     # Get the correspondence direction and check for a reverse arrow.
1216 :     $reverseFound = 1 if ($row[8] eq '<-');
1217 :     # If we're in converse mode, reformat the line.
1218 :     if ($converse) {
1219 : parrello 1.39 ReverseGeneCorrespondenceRow(\@row);
1220 : parrello 1.37 }
1221 :     # Validate the row.
1222 :     if (ValidateGeneCorrespondenceRow(\@row)) {
1223 : parrello 1.44 Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
1224 : parrello 1.37 $error = 1;
1225 :     }
1226 :     # If this row is in the correct direction, keep it.
1227 : parrello 1.40 if ($all || $row[8] ne '<-') {
1228 : parrello 1.37 push @corrList, \@row;
1229 :     }
1230 :     }
1231 :     # Close the input file.
1232 :     close $ih;
1233 : parrello 1.57 # If we have no errors, keep the result.
1234 : parrello 1.37 if (! $error) {
1235 : parrello 1.57 $retVal = \@corrList;
1236 : parrello 1.37 }
1237 :     # Return the result (if any).
1238 :     return $retVal;
1239 :     }
1240 :    
1241 : parrello 1.39 =head3 ReverseGeneCorrespondenceRow
1242 :    
1243 :     ServerThing::ReverseGeneCorrespondenceRow($row)
1244 :    
1245 :     Convert a gene correspondence row to represent the converse correspondence. The
1246 :     elements in the row will be reordered to represent a correspondence from the
1247 :     target genome to the source genome.
1248 :    
1249 :     =over 4
1250 :    
1251 :     =item row
1252 :    
1253 :     Reference to a list containing a single row from a L</Gene Correspondence List>.
1254 :    
1255 :     =back
1256 :    
1257 :     =cut
1258 :    
1259 :     sub ReverseGeneCorrespondenceRow {
1260 :     # Get the parameters.
1261 :     my ($row) = @_;
1262 :     # Flip the row in place.
1263 :     ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
1264 : parrello 1.41 $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
1265 : parrello 1.39 $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
1266 : parrello 1.41 # Flip the arrow.
1267 :     $row->[8] = ARROW_FLIP->{$row->[8]};
1268 :     # Flip the pairs.
1269 : parrello 1.42 my @elements = split /,/, $row->[3];
1270 : parrello 1.45 $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
1271 : parrello 1.39 }
1272 : parrello 1.37
1273 :     =head3 ValidateGeneCorrespondenceRow
1274 :    
1275 :     my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
1276 :    
1277 :     Validate a gene correspondence row. The numeric fields are checked to insure they
1278 :     are numeric and the source and target gene IDs are validated. The return value will
1279 :     indicate the number of errors found.
1280 :    
1281 :     =over 4
1282 :    
1283 :     =item row
1284 :    
1285 :     Reference to a list containing a single row from a L</Gene Correspondence List>.
1286 :    
1287 :     =item RETURN
1288 :    
1289 :     Returns the number of errors found in the row. A return of C<0> indicates the row
1290 :     is valid.
1291 :    
1292 :     =back
1293 :    
1294 :     =cut
1295 :    
1296 :     sub ValidateGeneCorrespondenceRow {
1297 :     # Get the parameters.
1298 :     my ($row, $genome1, $genome2) = @_;
1299 :     # Denote no errors have been found so far.
1300 :     my $retVal = 0;
1301 :     # Check for non-numeric values in the number columns.
1302 :     for my $col (@{NUM_COLS()}) {
1303 :     unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
1304 : parrello 1.44 Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
1305 : parrello 1.37 $retVal++;
1306 :     }
1307 :     }
1308 :     # Check the gene IDs.
1309 :     for my $col (0, 1) {
1310 :     unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
1311 : parrello 1.44 Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
1312 : parrello 1.37 $retVal++;
1313 : parrello 1.36 }
1314 :     }
1315 : parrello 1.37 # Verify the arrow.
1316 :     unless (exists ARROW_FLIP->{$row->[8]}) {
1317 : parrello 1.44 Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
1318 : parrello 1.37 $retVal++;
1319 :     }
1320 :     # Return the error count.
1321 : parrello 1.36 return $retVal;
1322 :     }
1323 :    
1324 : parrello 1.53 =head3 GetCorrespondenceData
1325 :    
1326 :     my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
1327 :    
1328 :     Return the L</Gene Correspondence List> for the specified source and target genomes. If the
1329 :     list is in a file, it will be read. If the file does not exist, it may be created.
1330 :    
1331 :     =over 4
1332 :    
1333 :     =item genome1
1334 :    
1335 :     ID of the source genome.
1336 :    
1337 :     =item genome2
1338 :    
1339 :     ID of the target genome.
1340 :    
1341 :     =item passive
1342 :    
1343 :     If TRUE, then the correspondence file will not be created if it does not exist.
1344 :    
1345 :     =item full
1346 :    
1347 :     If TRUE, then both directions of the correspondence will be represented; otherwise, only
1348 :     correspondences from the source to the target (including bidirectional corresopndences)
1349 :     will be included.
1350 :    
1351 :     =item RETURN
1352 :    
1353 :     Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
1354 :     undefined value if an error occurs or no file exists and passive mode was specified.
1355 :    
1356 :     =back
1357 :    
1358 :     =cut
1359 :    
1360 :     sub GetCorrespondenceData {
1361 :     # Get the parameters.
1362 :     my ($genome1, $genome2, $passive, $full) = @_;
1363 :     # Declare the return variable.
1364 :     my $retVal;
1365 :     # Check for a gene correspondence file.
1366 :     my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1367 :     if ($fileName) {
1368 :     # Here we found one, so read it in.
1369 :     $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1370 :     }
1371 :     # Were we successful?
1372 :     if (! defined $retVal) {
1373 :     # Here we either don't have a correspondence file, or the one that's there is
1374 :     # invalid. If we are NOT in passive mode, then this means we need to create
1375 :     # the file.
1376 :     if (! $passive) {
1377 :     ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1378 :     # Now try reading the new file.
1379 :     if (defined $fileName) {
1380 :     $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1381 :     }
1382 :     }
1383 :     }
1384 :     # Return the result.
1385 :     return $retVal;
1386 :    
1387 :     }
1388 :    
1389 : parrello 1.9
1390 :     =head2 Internal Utility Methods
1391 :    
1392 :     The methods in this section are used internally by this package.
1393 :    
1394 : parrello 1.6 =head3 RunRequest
1395 :    
1396 : parrello 1.62 ServerThing::RunRequest($cgi, $serverThing, $docURL);
1397 : parrello 1.6
1398 :     Run a request from the specified server using the incoming CGI parameter
1399 :     object for the parameters.
1400 :    
1401 :     =over 4
1402 :    
1403 :     =item cgi
1404 :    
1405 : parrello 1.49 CGI query object containing the parameters from the web service request. The
1406 :     significant parameters are as follows.
1407 :    
1408 :     =over 8
1409 :    
1410 :     =item function
1411 :    
1412 :     Name of the function to run.
1413 :    
1414 :     =item args
1415 :    
1416 :     Parameters for the function.
1417 :    
1418 :     =item encoding
1419 :    
1420 :     Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1421 :     by the Java interface).
1422 :    
1423 :     =back
1424 :    
1425 :     Certain unusual requests can come in outside of the standard function interface.
1426 :     These are indicated by special parameters that override all the others.
1427 :    
1428 :     =over 8
1429 :    
1430 :     =item pod
1431 :    
1432 :     Display a POD documentation module.
1433 :    
1434 :     =item code
1435 :    
1436 :     Display an example code file.
1437 :    
1438 :     =item file
1439 :    
1440 :     Transfer a file (not implemented).
1441 :    
1442 :     =back
1443 : parrello 1.6
1444 : parrello 1.13 =item serverThing
1445 : parrello 1.6
1446 : parrello 1.13 Server object against which to run the request.
1447 : parrello 1.6
1448 : parrello 1.62 =item docURL
1449 :    
1450 :     URL to use for POD documentation requests.
1451 :    
1452 : parrello 1.6 =back
1453 :    
1454 :     =cut
1455 :    
1456 :     sub RunRequest {
1457 :     # Get the parameters.
1458 : parrello 1.13 my ($cgi, $serverThing, $docURL) = @_;
1459 : parrello 1.62 # Make the CGI object available to the server.
1460 :     $serverThing->{cgi} = $cgi;
1461 : parrello 1.9 # Determine the request type.
1462 : parrello 1.52 my $module = $cgi->param('pod');
1463 :     if ($module) {
1464 :     # Here we have a documentation request.
1465 :     if ($module eq 'ServerScripts') {
1466 :     # Here we list the server scripts.
1467 :     require ListServerScripts;
1468 :     ListServerScripts::main();
1469 :     } else {
1470 :     # In this case, we produce POD HTML.
1471 :     ProducePod($cgi->param('pod'));
1472 :     }
1473 : disz 1.31 } elsif ($cgi->param('code')) {
1474 : parrello 1.32 # Here the user wants to see the code for one of our scripts.
1475 :     LineNumberize($cgi->param('code'));
1476 : parrello 1.9 } elsif ($cgi->param('file')) {
1477 :     # Here we have a file request. Process according to the type.
1478 :     my $type = $cgi->param('file');
1479 :     if ($type eq 'open') {
1480 :     OpenFile($cgi->param('name'));
1481 :     } elsif ($type eq 'create') {
1482 :     CreateFile();
1483 :     } elsif ($type eq 'read') {
1484 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
1485 :     } elsif ($type eq 'write') {
1486 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
1487 :     } else {
1488 :     Die("Invalid file function \"$type\".");
1489 : parrello 1.4 }
1490 : parrello 1.1 } else {
1491 : parrello 1.9 # The default is a function request. Get the function name.
1492 : parrello 1.4 my $function = $cgi->param('function') || "";
1493 : parrello 1.15 Trace("Server function for task $$ is $function.") if T(3);
1494 : parrello 1.4 # Insure the function name is valid.
1495 : devoid 1.75 if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1496 :     SendError("Invalid function name.", "$function not found.")
1497 :     } else {
1498 :     # Determing the encoding scheme. The default is YAML.
1499 :     my $encoding = $cgi->param('encoding') || 'yaml';
1500 :     # Optional callback for json encoded documents
1501 :     my $callback = $cgi->param('callback');
1502 :     # The parameter structure will go in here.
1503 :     my $args = {};
1504 :     # Start the timer.
1505 :     my $start = time();
1506 :     # The output document goes in here.
1507 :     my $document;
1508 :     # Protect from errors.
1509 :     eval {
1510 :     # Here we parse the arguments. This is affected by the encoding parameter.
1511 :     # Get the argument string.
1512 :     my $argString = $cgi->param('args');
1513 :     # Only proceed if we found one.
1514 :     if ($argString) {
1515 :     if ($encoding eq 'yaml') {
1516 :     # Parse the arguments using YAML.
1517 :     $args = YAML::Load($argString);
1518 :     } elsif ($encoding eq 'json') {
1519 :     # Parse the arguments using JSON.
1520 :     Trace("Incoming string is:\n$argString") if T(3);
1521 :     $args = JSON::Any->jsonToObj($argString);
1522 :     } else {
1523 :     Die("Invalid encoding type $encoding.");
1524 :     }
1525 : devoid 1.74 }
1526 : devoid 1.75 };
1527 :     # Check to make sure we got everything.
1528 : parrello 1.1 if ($@) {
1529 : devoid 1.75 SendError($@, "Error formatting parameters.");
1530 :     } elsif (! $function) {
1531 :     SendError("No function specified.", "No function specified.");
1532 : parrello 1.1 } else {
1533 : devoid 1.75 # Insure we're connected to the correct database.
1534 :     my $dbName = $cgi->param('dbName');
1535 :     if ($dbName && exists $serverThing->{db}) {
1536 :     ChangeDB($serverThing, $dbName);
1537 :     }
1538 :     # Run the request.
1539 :     $document = eval { $serverThing->$function($args) };
1540 :     # If we have an error, create an error document.
1541 :     if ($@) {
1542 :     SendError($@, "Error detected by service.");
1543 :     Trace("Error encountered by service: $@") if T(0);
1544 : devoid 1.74 } else {
1545 : devoid 1.75 # No error, so we output the result. Start with an HTML header.
1546 :     if ($encoding eq 'yaml') {
1547 :     print $cgi->header(-type => 'text/plain');
1548 :     } else {
1549 :     print $cgi->header(-type => 'text/javascript');
1550 :     }
1551 :     # The nature of the output depends on the encoding type.
1552 :     eval {
1553 :     my $string;
1554 :     if ($encoding eq 'yaml') {
1555 :     $string = YAML::Dump($document);
1556 :     } elsif(defined($callback)) {
1557 :     $string = $callback . "(".JSON::Any->objToJson($document).")";
1558 :     } else {
1559 :     $string = JSON::Any->objToJson($document);
1560 :     }
1561 :     print $string;
1562 :     MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
1563 :     };
1564 :     if ($@) {
1565 :     SendError($@, "Error encoding result.");
1566 :     Trace("Error encoding result: $@") if T(0);
1567 :     }
1568 : parrello 1.63 }
1569 : parrello 1.1 }
1570 : devoid 1.75 # Stop the timer.
1571 :     my $duration = int(time() - $start + 0.5);
1572 :     Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1573 : parrello 1.1 }
1574 :     }
1575 :     }
1576 :    
1577 : parrello 1.9 =head3 CreateFile
1578 :    
1579 :     ServerThing::CreateFile();
1580 :    
1581 :     Create a new, empty temporary file and send its name back to the client.
1582 :    
1583 :     =cut
1584 :    
1585 :     sub CreateFile {
1586 :     ##TODO: Code
1587 :     }
1588 :    
1589 :     =head3 OpenFile
1590 : parrello 1.6
1591 : parrello 1.9 ServerThing::OpenFile($name);
1592 : parrello 1.1
1593 : parrello 1.9 Send the length of the named file back to the client.
1594 :    
1595 :     =over 4
1596 :    
1597 :     =item name
1598 :    
1599 :     ##TODO: name description
1600 :    
1601 :     =back
1602 :    
1603 :     =cut
1604 :    
1605 :     sub OpenFile {
1606 :     # Get the parameters.
1607 :     my ($name) = @_;
1608 :     ##TODO: Code
1609 :     }
1610 : parrello 1.1
1611 : parrello 1.9 =head3 ReadChunk
1612 : parrello 1.1
1613 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
1614 : parrello 1.1
1615 : parrello 1.9 Read the indicated number of bytes from the specified location of the
1616 :     named file and send them back to the client.
1617 : parrello 1.1
1618 :     =over 4
1619 :    
1620 :     =item name
1621 :    
1622 : parrello 1.9 ##TODO: name description
1623 : parrello 1.1
1624 : parrello 1.9 =item location
1625 : parrello 1.1
1626 : parrello 1.9 ##TODO: location description
1627 : parrello 1.1
1628 : parrello 1.9 =item size
1629 : parrello 1.1
1630 : parrello 1.9 ##TODO: size description
1631 : parrello 1.1
1632 :     =back
1633 :    
1634 :     =cut
1635 :    
1636 : parrello 1.9 sub ReadChunk {
1637 : parrello 1.1 # Get the parameters.
1638 : parrello 1.9 my ($name, $location, $size) = @_;
1639 :     ##TODO: Code
1640 : parrello 1.1 }
1641 :    
1642 : parrello 1.9 =head3 WriteChunk
1643 : parrello 1.1
1644 : parrello 1.9 ServerThing::WriteChunk($name, $data);
1645 : parrello 1.8
1646 : parrello 1.9 Write the specified data to the named file.
1647 : parrello 1.8
1648 :     =over 4
1649 :    
1650 :     =item name
1651 :    
1652 : parrello 1.9 ##TODO: name description
1653 :    
1654 :     =item data
1655 :    
1656 :     ##TODO: data description
1657 :    
1658 :     =back
1659 :    
1660 :     =cut
1661 :    
1662 :     sub WriteChunk {
1663 :     # Get the parameters.
1664 :     my ($name, $data) = @_;
1665 :     ##TODO: Code
1666 :     }
1667 :    
1668 :    
1669 : disz 1.31 =head3 LineNumberize
1670 :    
1671 :     ServerThing::LineNumberize($module);
1672 :    
1673 :     Output the module line by line with line numbers
1674 :    
1675 :     =over 4
1676 :    
1677 :     =item module
1678 :    
1679 :     Name of the module to line numberized
1680 :    
1681 :     =back
1682 :    
1683 :     =cut
1684 :    
1685 :     sub LineNumberize {
1686 :     # Get the parameters.
1687 :     my ($module) = @_;
1688 :     my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1689 :     # Start the output page.
1690 :     print CGI::header();
1691 :     print CGI::start_html(-title => 'Documentation Page',
1692 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1693 :     # Protect from errors.
1694 :     eval {
1695 : parrello 1.32 if (-e $fks_path) {
1696 :     print "<pre>\n";
1697 :     my $i = 1;
1698 :     foreach my $line (`cat $fks_path`) {
1699 :     print "$i.\t$line";
1700 :     $i++;
1701 :     }
1702 :     print "</pre>\n";
1703 :     } else {
1704 :     print "File $fks_path not found";
1705 :     }
1706 : disz 1.31 };
1707 :     # Process any error.
1708 :     if ($@) {
1709 :     print CGI::blockquote({ class => 'error' }, $@);
1710 :     }
1711 :     # Close off the page.
1712 :     print CGI::end_html();
1713 :    
1714 :     }
1715 :    
1716 : parrello 1.9 =head3 ProducePod
1717 :    
1718 :     ServerThing::ProducePod($module);
1719 :    
1720 :     Output the POD documentation for the specified module.
1721 :    
1722 :     =over 4
1723 : parrello 1.8
1724 : parrello 1.9 =item module
1725 : parrello 1.8
1726 : parrello 1.9 Name of the module whose POD document is to be displayed.
1727 : parrello 1.8
1728 :     =back
1729 :    
1730 :     =cut
1731 :    
1732 : parrello 1.9 sub ProducePod {
1733 : parrello 1.8 # Get the parameters.
1734 : parrello 1.9 my ($module) = @_;
1735 :     # Start the output page.
1736 :     print CGI::header();
1737 : parrello 1.46 print CGI::start_html(-title => "$module Documentation Page",
1738 : parrello 1.9 -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1739 :     # Protect from errors.
1740 :     eval {
1741 :     # We'll format the HTML text in here.
1742 :     require DocUtils;
1743 : devoid 1.75 my $html = DocUtils::ShowPod($module, "http://pubseed.theseed.org/sapling/server.cgi?pod=");
1744 : parrello 1.9 # Output the POD HTML.
1745 :     print $html;
1746 :     };
1747 :     # Process any error.
1748 :     if ($@) {
1749 :     print CGI::blockquote({ class => 'error' }, $@);
1750 : parrello 1.8 }
1751 : parrello 1.9 # Close off the page.
1752 :     print CGI::end_html();
1753 :    
1754 : parrello 1.8 }
1755 :    
1756 :     =head3 TraceErrorLog
1757 :    
1758 :     ServerThing::TraceErrorLog($name, $errorLog);
1759 :    
1760 :     Trace the specified error log file. This is a very dinky routine that
1761 :     performs a task required by L</RunTool> in multiple places.
1762 :    
1763 :     =over 4
1764 :    
1765 :     =item name
1766 :    
1767 :     Name of the tool relevant to the log file.
1768 :    
1769 :     =item errorLog
1770 :    
1771 :     Name of the log file.
1772 :    
1773 :     =back
1774 :    
1775 :     =cut
1776 :    
1777 :     sub TraceErrorLog {
1778 :     my ($name, $errorLog) = @_;
1779 :     my $errorData = Tracer::GetFile($errorLog);
1780 :     Trace("$name error log:\n$errorData");
1781 :     }
1782 :    
1783 : parrello 1.10 =head3 SendError
1784 :    
1785 :     ServerThing::SendError($message, $status);
1786 :    
1787 :     Fail an HTTP request with the specified error message and the specified
1788 :     status message.
1789 :    
1790 :     =over 4
1791 :    
1792 :     =item message
1793 :    
1794 :     Detailed error message. This is sent as the page content.
1795 :    
1796 :     =item status
1797 :    
1798 :     Status message. This is sent as part of the status code.
1799 :    
1800 :     =back
1801 :    
1802 :     =cut
1803 :    
1804 :     sub SendError {
1805 :     # Get the parameters.
1806 :     my ($message, $status) = @_;
1807 : parrello 1.78 warn ("SAS Error \"$status\" $message\n");
1808 : parrello 1.30 # Check for a DBserver error. These can be retried and get a special status
1809 :     # code.
1810 :     my $realStatus;
1811 :     if ($message =~ /DBServer Error:\s+/) {
1812 :     $realStatus = "503 $status";
1813 :     } else {
1814 : parrello 1.77 $realStatus = "512 $status";
1815 : parrello 1.30 }
1816 : parrello 1.10 # Print the header and the status message.
1817 :     print CGI::header(-type => 'text/plain',
1818 : parrello 1.30 -status => $realStatus);
1819 : parrello 1.10 # Print the detailed message.
1820 :     print $message;
1821 :     }
1822 :    
1823 :    
1824 : devoid 1.75 =head3 Log
1825 :    
1826 :     Log($msg);
1827 :    
1828 :     Write a message to the log. This is a temporary hack until we can figure out how to get
1829 :     normal tracing and error logging working.
1830 :    
1831 :     =over 4
1832 :    
1833 :     =item msg
1834 :    
1835 :     Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1836 :    
1837 :     =back
1838 :    
1839 :     =cut
1840 :    
1841 :     sub Log {
1842 :     # Get the parameters.
1843 :     my ($msg) = @_;
1844 :     # Open the log file for appending.
1845 :     open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1846 :     print $oh "$msg\n";
1847 :     close $oh;
1848 :     }
1849 :    
1850 : disz 1.31 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3