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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3