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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package ServerThing;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use YAML;
8 :     use ERDB;
9 :     use TestUtils;
10 :     use Time::HiRes;
11 : parrello 1.9 use File::Temp;
12 : parrello 1.10 use ErrorMessage;
13 : parrello 1.1 use CGI;
14 : parrello 1.9 no warnings qw(once);
15 : parrello 1.1
16 : parrello 1.11 # Maximum number of requests to run per invocation.
17 : parrello 1.29 use constant MAX_REQUESTS => 5000;
18 : parrello 1.11
19 : parrello 1.1 =head1 General Server Helper
20 :    
21 :     This package provides a method-- I<RunServer>-- that can be called from a CGI
22 : parrello 1.9 script to perform the duties of a FIG server. RunServer is called with two
23 :     parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
24 :     the first command-line parameter. The command-line parameter (if defined) will
25 :     be used as the tracing key, and also indicates that the script is being invoked
26 :     from the command line rather than over the web.
27 : parrello 1.1
28 :     =cut
29 :    
30 :     sub RunServer {
31 :     # Get the parameters.
32 : parrello 1.9 my ($serverName, $key) = @_;
33 : parrello 1.25 # Set up tracing. We never do CGI tracing here; the only question is whether
34 :     # or not the caller passed in a tracing key. If he didn't, we use the server
35 :     # name.
36 : parrello 1.33 warn "Key parameter is \"$key\". Server name is \"$serverName\".\n"; ##HACK
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 :     require "$serverName.pm";
44 :     };
45 :     # If we have an error, create an error document.
46 :     if ($@) {
47 :     SendError($@, "Could not load server module.");
48 :     } else {
49 :     # Having successfully loaded the server code, we create the object.
50 :     my $serverThing = eval("$serverName" . '->new()');
51 : parrello 1.15 Trace("$serverName object created for task $$.") if T(2);
52 : parrello 1.13 # If we have an error, create an error document.
53 :     if ($@) {
54 :     SendError($@, "Could not start server.");
55 : parrello 1.3 } else {
56 : parrello 1.13 # No error, so now we can process the request.
57 :     my $cgi;
58 :     if (! defined $key) {
59 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
60 :     if ($ENV{REQUEST_METHOD} eq '') {
61 :     # Count the number of requests.
62 :     my $requests = 0;
63 : parrello 1.24 Trace("Starting Fast CGI loop.") if T(3);
64 : parrello 1.13 # Loop through the fast CGI requests. If we have request throttling,
65 :     # we exit after a maximum number of requests has been exceeded.
66 :     require CGI::Fast;
67 : parrello 1.23 while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
68 :     ($cgi = new CGI::Fast())) {
69 : parrello 1.13 RunRequest($cgi, $serverThing);
70 : parrello 1.16 Trace("Request $requests complete in task $$.") if T(3);
71 : parrello 1.13 }
72 : parrello 1.15 Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
73 : parrello 1.13 } else {
74 :     # Here we have a normal web service (non-Fast).
75 :     my $cgi = CGI->new();
76 :     # Check for a source parameter. This gets used as the tracing key.
77 :     $key = $cgi->param('source');
78 :     # Run this request.
79 :     RunRequest($cgi, $serverThing);
80 :     }
81 : parrello 1.6 } else {
82 : parrello 1.13 # We're being invoked from the command line. Use the tracing
83 :     # key to find the parm file and create the CGI object from that.
84 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
85 :     $cgi = CGI->new($ih);
86 :     # Run this request.
87 :     RunRequest($cgi, $serverThing);
88 : parrello 1.6 }
89 : parrello 1.3 }
90 : parrello 1.1 }
91 : parrello 1.6 }
92 :    
93 :    
94 : parrello 1.9 =head2 Server Utility Methods
95 :    
96 :     The methods in this section are utilities of general use to the various
97 :     server modules.
98 :    
99 : parrello 1.21 =head3 AddSubsystemFilter
100 :    
101 :     ServerThing::AddSubsystemFilter(\$filter, $args);
102 :    
103 :     Add subsystem filtering information to the specified query filter clause
104 :     based on data in the argument hash. The argument hash will be checked for
105 : parrello 1.22 the C<-usable> parameter, which includes or excludes unusuable subsystems, and
106 :     the C<-exclude> parameter, which lists types of subsystems that should be
107 : parrello 1.21 excluded.
108 :    
109 :     =over 4
110 :    
111 :     =item filter
112 :    
113 :     Reference to the current filter string. If additional filtering is required,
114 :     this string will be updated.
115 :    
116 :     =item args
117 :    
118 :     Reference to the parameter hash for the current server call. This hash will
119 : parrello 1.22 be examined for the C<-usable> and C<-exclude> parameters.
120 : parrello 1.21
121 :     =back
122 :    
123 :     =cut
124 :    
125 :     use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
126 :     experimental => 1,
127 :     private => 1 };
128 :    
129 :     sub AddSubsystemFilter {
130 :     # Get the parameters.
131 :     my ($filter, $args) = @_;
132 :     # We'll put the new filter stuff in here.
133 :     my @newFilters;
134 :     # Unless unusable subsystems are desired, we must add a clause to the filter.
135 : parrello 1.22 # The default is that only usable subsystems are included.
136 :     my $usable = 1;
137 :     # This default can be overridden by the "-usable" parameter.
138 :     if (exists $args->{-usable}) {
139 :     $usable = $args->{-usable};
140 :     }
141 :     # If we're restricting to usable subsystems, add a filter to that effect.
142 :     if ($usable) {
143 : parrello 1.21 push @newFilters, "Subsystem(usable) = 1";
144 :     }
145 :     # Check for exclusion filters.
146 :     my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
147 :     for my $exclusion (@$exclusions) {
148 :     if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
149 :     Confess("Invalid exclusion type \"$exclusion\".");
150 :     } else {
151 :     # Here we have to exclude subsystems of the specified type.
152 :     push @newFilters, "Subsystem($exclusion) = 0";
153 :     }
154 :     }
155 :     # Do we need to update the incoming filter?
156 :     if (@newFilters) {
157 :     # Yes. If the incoming filter is nonempty, push it onto the list
158 :     # so it gets included in the result.
159 :     if ($$filter) {
160 :     push @newFilters, $$filter;
161 :     }
162 :     # Put all the filters together to form the new filter.
163 :     $$filter = join(" AND ", @newFilters);
164 : parrello 1.26 Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
165 : parrello 1.21 }
166 :     }
167 :    
168 :    
169 :    
170 : parrello 1.9 =head3 GetIdList
171 :    
172 : parrello 1.19 my $ids = ServerThing::GetIdList($name => $args, $optional);
173 : parrello 1.9
174 :     Get a named list of IDs from an argument structure. If the IDs are
175 :     missing, or are not a list, an error will occur.
176 :    
177 :     =over 4
178 :    
179 :     =item name
180 :    
181 :     Name of the argument structure member that should contain the ID list.
182 :    
183 :     =item args
184 :    
185 :     Argument structure from which the ID list is to be extracted.
186 :    
187 : parrello 1.19 =item optional (optional)
188 :    
189 :     If TRUE, then a missing value will not generate an error. Instead, an empty list
190 :     will be returned. The default is FALSE.
191 :    
192 : parrello 1.9 =item RETURN
193 :    
194 :     Returns a reference to a list of IDs taken from the argument structure.
195 :    
196 :     =back
197 :    
198 :     =cut
199 :    
200 :     sub GetIdList {
201 :     # Get the parameters.
202 : parrello 1.19 my ($name, $args, $optional) = @_;
203 : parrello 1.32 # Check the argument format.
204 :     if (ref $args ne 'HASH') {
205 :     Confess("No '$name' parameter present.");
206 :     }
207 : parrello 1.9 # Try to get the IDs from the argument structure.
208 :     my $retVal = $args->{$name};
209 : parrello 1.19 # Was a member found?
210 :     if (! defined $retVal) {
211 :     # No. If we're optional, return an empty list; otherwise throw an error.
212 :     if ($optional) {
213 :     $retVal = [];
214 :     } else {
215 :     Confess("No '$name' parameter found.");
216 :     }
217 :     } else {
218 :     # Here we found something. Get the parameter type. We was a list reference.
219 :     # If it's a scalar, we'll convert it to a singleton list. If it's anything
220 :     # else, it's an error.
221 :     my $type = ref $retVal;
222 :     if (! $type) {
223 :     $retVal = [$retVal];
224 :     } elsif ($type ne 'ARRAY') {
225 :     Confess("The '$name' parameter must be a list.");
226 :     }
227 : parrello 1.9 }
228 :     # Return the result.
229 :     return $retVal;
230 :     }
231 :    
232 :    
233 :     =head3 RunTool
234 :    
235 :     ServerThing::RunTool($name => $cmd);
236 :    
237 :     Run a command-line tool. A non-zero return value from the tool will cause
238 :     a fatal error, and the tool's error log will be traced.
239 :    
240 :     =over 4
241 :    
242 :     =item name
243 :    
244 :     Name to give to the tool in the error output.
245 :    
246 :     =item cmd
247 :    
248 :     Command to use for running the tool. This should be the complete command line.
249 :     The command should not contain any fancy piping, though it may redirect the
250 :     standard input and output. The command will be modified by this method to
251 :     redirect the error output to a temporary file.
252 :    
253 :     =back
254 :    
255 :     =cut
256 :    
257 :     sub RunTool {
258 :     # Get the parameters.
259 :     my ($name, $cmd) = @_;
260 :     # Compute the log file name.
261 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
262 :     # Execute the command.
263 : parrello 1.26 Trace("Executing command: $cmd") if T(ServerUtilities => 3);
264 : parrello 1.9 my $res = system("$cmd 2> $errorLog");
265 : parrello 1.26 Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
266 : parrello 1.9 # Check the result code.
267 :     if ($res != 0) {
268 :     # We have an error. If tracing is on, trace it.
269 : parrello 1.26 if (T(ServerUtilities => 1)) {
270 : parrello 1.9 TraceErrorLog($name, $errorLog);
271 :     }
272 :     # Delete the error log.
273 :     unlink $errorLog;
274 :     # Confess the error.
275 : parrello 1.10 Confess("$name command failed with error code $res.");
276 : parrello 1.9 } else {
277 :     # Everything worked. Trace the error log if necessary.
278 : parrello 1.26 if (T(ServerUtilities => 3) && -s $errorLog) {
279 : parrello 1.9 TraceErrorLog($name, $errorLog);
280 :     }
281 :     # Delete the error log if there is one.
282 :     unlink $errorLog;
283 :     }
284 :     }
285 :    
286 :    
287 :     =head2 Internal Utility Methods
288 :    
289 :     The methods in this section are used internally by this package.
290 :    
291 : parrello 1.6 =head3 RunRequest
292 :    
293 : parrello 1.9 ServerThing::RunRequest($cgi, $serverName);
294 : parrello 1.6
295 :     Run a request from the specified server using the incoming CGI parameter
296 :     object for the parameters.
297 :    
298 :     =over 4
299 :    
300 :     =item cgi
301 :    
302 :     CGI query object containing the parameters from the web service request.
303 :    
304 : parrello 1.13 =item serverThing
305 : parrello 1.6
306 : parrello 1.13 Server object against which to run the request.
307 : parrello 1.6
308 :     =back
309 :    
310 :     =cut
311 :    
312 :     sub RunRequest {
313 :     # Get the parameters.
314 : parrello 1.13 my ($cgi, $serverThing, $docURL) = @_;
315 : parrello 1.9 # Determine the request type.
316 :     if ($cgi->param('pod')) {
317 : parrello 1.4 # Here we have a documentation request. In this case, we produce POD HTML.
318 : parrello 1.9 ProducePod($cgi->param('pod'));
319 : disz 1.31 } elsif ($cgi->param('code')) {
320 : parrello 1.32 # Here the user wants to see the code for one of our scripts.
321 :     LineNumberize($cgi->param('code'));
322 : parrello 1.9 } elsif ($cgi->param('file')) {
323 :     # Here we have a file request. Process according to the type.
324 :     my $type = $cgi->param('file');
325 :     if ($type eq 'open') {
326 :     OpenFile($cgi->param('name'));
327 :     } elsif ($type eq 'create') {
328 :     CreateFile();
329 :     } elsif ($type eq 'read') {
330 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
331 :     } elsif ($type eq 'write') {
332 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
333 :     } else {
334 :     Die("Invalid file function \"$type\".");
335 : parrello 1.4 }
336 : parrello 1.1 } else {
337 : parrello 1.9 # The default is a function request. Get the function name.
338 : parrello 1.4 my $function = $cgi->param('function') || "";
339 : parrello 1.15 Trace("Server function for task $$ is $function.") if T(3);
340 : parrello 1.4 # Insure the function name is valid.
341 :     Die("Invalid function name.")
342 :     if $function =~ /\W/;
343 :     # The parameter structure will go in here.
344 :     my $args;
345 :     # Start the timer.
346 :     my $start = time();
347 :     # The output document goes in here.
348 :     my $document;
349 :     # The sapling database goes in here.
350 :     my $sapling;
351 :     # Protect from errors.
352 : parrello 1.1 eval {
353 : parrello 1.4 # Parse the arguments.
354 :     $args = YAML::Load($cgi->param('args'));
355 : parrello 1.1 };
356 : parrello 1.4 # Check to make sure we got everything.
357 : parrello 1.1 if ($@) {
358 : parrello 1.10 SendError($@, "Error formatting parameters.");
359 : parrello 1.4 } elsif (! $function) {
360 : parrello 1.10 SendError("No function specified.", "No function specified.");
361 : parrello 1.1 } else {
362 : parrello 1.30 $document = eval { $serverThing->$function($args) };
363 : parrello 1.1 # If we have an error, create an error document.
364 :     if ($@) {
365 : parrello 1.13 SendError($@, "Error detected by service.");
366 : parrello 1.32 Trace("Error encountered by service: $@") if T(0);
367 : parrello 1.1 } else {
368 : parrello 1.13 # No error, so we output the result.
369 :     print $cgi->header(-type => 'text/plain');
370 : parrello 1.18 my $string = YAML::Dump($document);
371 :     print $string;
372 :     MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
373 : parrello 1.1 }
374 :     }
375 : parrello 1.4 # Stop the timer.
376 :     my $duration = int(time() - $start + 0.5);
377 : parrello 1.29 Trace("Function $function executed in $duration seconds by task $$.") if T(2);
378 : parrello 1.1 }
379 :     }
380 :    
381 : parrello 1.9 =head3 CreateFile
382 :    
383 :     ServerThing::CreateFile();
384 :    
385 :     Create a new, empty temporary file and send its name back to the client.
386 :    
387 :     =cut
388 :    
389 :     sub CreateFile {
390 :     ##TODO: Code
391 :     }
392 :    
393 :     =head3 OpenFile
394 : parrello 1.6
395 : parrello 1.9 ServerThing::OpenFile($name);
396 : parrello 1.1
397 : parrello 1.9 Send the length of the named file back to the client.
398 :    
399 :     =over 4
400 :    
401 :     =item name
402 :    
403 :     ##TODO: name description
404 :    
405 :     =back
406 :    
407 :     =cut
408 :    
409 :     sub OpenFile {
410 :     # Get the parameters.
411 :     my ($name) = @_;
412 :     ##TODO: Code
413 :     }
414 : parrello 1.1
415 : parrello 1.9 =head3 ReadChunk
416 : parrello 1.1
417 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
418 : parrello 1.1
419 : parrello 1.9 Read the indicated number of bytes from the specified location of the
420 :     named file and send them back to the client.
421 : parrello 1.1
422 :     =over 4
423 :    
424 :     =item name
425 :    
426 : parrello 1.9 ##TODO: name description
427 : parrello 1.1
428 : parrello 1.9 =item location
429 : parrello 1.1
430 : parrello 1.9 ##TODO: location description
431 : parrello 1.1
432 : parrello 1.9 =item size
433 : parrello 1.1
434 : parrello 1.9 ##TODO: size description
435 : parrello 1.1
436 :     =back
437 :    
438 :     =cut
439 :    
440 : parrello 1.9 sub ReadChunk {
441 : parrello 1.1 # Get the parameters.
442 : parrello 1.9 my ($name, $location, $size) = @_;
443 :     ##TODO: Code
444 : parrello 1.1 }
445 :    
446 : parrello 1.9 =head3 WriteChunk
447 : parrello 1.1
448 : parrello 1.9 ServerThing::WriteChunk($name, $data);
449 : parrello 1.8
450 : parrello 1.9 Write the specified data to the named file.
451 : parrello 1.8
452 :     =over 4
453 :    
454 :     =item name
455 :    
456 : parrello 1.9 ##TODO: name description
457 :    
458 :     =item data
459 :    
460 :     ##TODO: data description
461 :    
462 :     =back
463 :    
464 :     =cut
465 :    
466 :     sub WriteChunk {
467 :     # Get the parameters.
468 :     my ($name, $data) = @_;
469 :     ##TODO: Code
470 :     }
471 :    
472 :    
473 : disz 1.31 =head3 LineNumberize
474 :    
475 :     ServerThing::LineNumberize($module);
476 :    
477 :     Output the module line by line with line numbers
478 :    
479 :     =over 4
480 :    
481 :     =item module
482 :    
483 :     Name of the module to line numberized
484 :    
485 :     =back
486 :    
487 :     =cut
488 :    
489 :     sub LineNumberize {
490 :     # Get the parameters.
491 :     my ($module) = @_;
492 :     my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
493 :     # Start the output page.
494 :     print CGI::header();
495 :     print CGI::start_html(-title => 'Documentation Page',
496 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
497 :     # Protect from errors.
498 :     eval {
499 : parrello 1.32 if (-e $fks_path) {
500 :     print "<pre>\n";
501 :     my $i = 1;
502 :     foreach my $line (`cat $fks_path`) {
503 :     print "$i.\t$line";
504 :     $i++;
505 :     }
506 :     print "</pre>\n";
507 :     } else {
508 :     print "File $fks_path not found";
509 :     }
510 : disz 1.31 };
511 :     # Process any error.
512 :     if ($@) {
513 :     print CGI::blockquote({ class => 'error' }, $@);
514 :     }
515 :     # Close off the page.
516 :     print CGI::end_html();
517 :    
518 :     }
519 :    
520 : parrello 1.9 =head3 ProducePod
521 :    
522 :     ServerThing::ProducePod($module);
523 :    
524 :     Output the POD documentation for the specified module.
525 :    
526 :     =over 4
527 : parrello 1.8
528 : parrello 1.9 =item module
529 : parrello 1.8
530 : parrello 1.9 Name of the module whose POD document is to be displayed.
531 : parrello 1.8
532 :     =back
533 :    
534 :     =cut
535 :    
536 : parrello 1.9 sub ProducePod {
537 : parrello 1.8 # Get the parameters.
538 : parrello 1.9 my ($module) = @_;
539 :     # Start the output page.
540 :     print CGI::header();
541 :     print CGI::start_html(-title => 'Documentation Page',
542 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
543 :     # Protect from errors.
544 :     eval {
545 :     # We'll format the HTML text in here.
546 :     require DocUtils;
547 : parrello 1.20 my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
548 : parrello 1.9 # Output the POD HTML.
549 :     print $html;
550 :     };
551 :     # Process any error.
552 :     if ($@) {
553 :     print CGI::blockquote({ class => 'error' }, $@);
554 : parrello 1.8 }
555 : parrello 1.9 # Close off the page.
556 :     print CGI::end_html();
557 :    
558 : parrello 1.8 }
559 :    
560 :     =head3 TraceErrorLog
561 :    
562 :     ServerThing::TraceErrorLog($name, $errorLog);
563 :    
564 :     Trace the specified error log file. This is a very dinky routine that
565 :     performs a task required by L</RunTool> in multiple places.
566 :    
567 :     =over 4
568 :    
569 :     =item name
570 :    
571 :     Name of the tool relevant to the log file.
572 :    
573 :     =item errorLog
574 :    
575 :     Name of the log file.
576 :    
577 :     =back
578 :    
579 :     =cut
580 :    
581 :     sub TraceErrorLog {
582 :     my ($name, $errorLog) = @_;
583 :     my $errorData = Tracer::GetFile($errorLog);
584 :     Trace("$name error log:\n$errorData");
585 :     }
586 :    
587 : parrello 1.10 =head3 SendError
588 :    
589 :     ServerThing::SendError($message, $status);
590 :    
591 :     Fail an HTTP request with the specified error message and the specified
592 :     status message.
593 :    
594 :     =over 4
595 :    
596 :     =item message
597 :    
598 :     Detailed error message. This is sent as the page content.
599 :    
600 :     =item status
601 :    
602 :     Status message. This is sent as part of the status code.
603 :    
604 :     =back
605 :    
606 :     =cut
607 :    
608 :     sub SendError {
609 :     # Get the parameters.
610 :     my ($message, $status) = @_;
611 :     Trace("Error \"$status\" $message") if T(2);
612 : parrello 1.30 # Check for a DBserver error. These can be retried and get a special status
613 :     # code.
614 :     my $realStatus;
615 :     if ($message =~ /DBServer Error:\s+/) {
616 :     $realStatus = "503 $status";
617 :     } else {
618 :     $realStatus = "500 $status";
619 :     }
620 : parrello 1.10 # Print the header and the status message.
621 :     print CGI::header(-type => 'text/plain',
622 : parrello 1.30 -status => $realStatus);
623 : parrello 1.10 # Print the detailed message.
624 :     print $message;
625 :     }
626 :    
627 :    
628 : disz 1.31 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3