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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (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.15 use constant MAX_REQUESTS => 500;
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 :     # Turn off YAML compression, which causes problems with some of our hash keys.
34 :     $YAML::CompressSeries = 0;
35 : parrello 1.13 # Create the server object.
36 : parrello 1.15 Trace("Requiring $serverName for task $$.") if T(3);
37 : parrello 1.13 eval {
38 :     require "$serverName.pm";
39 :     };
40 :     # If we have an error, create an error document.
41 :     if ($@) {
42 :     SendError($@, "Could not load server module.");
43 :     } else {
44 :     # Having successfully loaded the server code, we create the object.
45 :     my $serverThing = eval("$serverName" . '->new()');
46 : parrello 1.15 Trace("$serverName object created for task $$.") if T(2);
47 : parrello 1.13 # If we have an error, create an error document.
48 :     if ($@) {
49 :     SendError($@, "Could not start server.");
50 : parrello 1.3 } else {
51 : parrello 1.13 # No error, so now we can process the request.
52 :     my $cgi;
53 :     if (! defined $key) {
54 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
55 :     if ($ENV{REQUEST_METHOD} eq '') {
56 :     # Here we're doing Fast CGI. In this case, the tracing key is the
57 :     # server name.
58 :     ETracing($serverName);
59 :     # Count the number of requests.
60 :     my $requests = 0;
61 :     # Loop through the fast CGI requests. If we have request throttling,
62 :     # we exit after a maximum number of requests has been exceeded.
63 :     require CGI::Fast;
64 :     while (($cgi = new CGI::Fast()) &&
65 :     (MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS)) {
66 :     RunRequest($cgi, $serverThing);
67 : parrello 1.16 Trace("Request $requests complete in task $$.") if T(3);
68 : parrello 1.13 }
69 : parrello 1.15 Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
70 : parrello 1.13 } else {
71 :     # Here we have a normal web service (non-Fast).
72 :     my $cgi = CGI->new();
73 :     # Check for a source parameter. This gets used as the tracing key.
74 :     $key = $cgi->param('source');
75 :     if (! $key) {
76 :     # No source parameter, so do normal setup. Note we turn off
77 :     # CGI parameter tracing.
78 :     ETracing($cgi, 'noParms');
79 :     } else {
80 :     # Set up tracing using the specified key.
81 :     ETracing($key);
82 :     }
83 :     # Run this request.
84 :     RunRequest($cgi, $serverThing);
85 :     }
86 : parrello 1.6 } else {
87 : parrello 1.13 # We're being invoked from the command line. Use the tracing
88 :     # key to find the parm file and create the CGI object from that.
89 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
90 :     $cgi = CGI->new($ih);
91 : parrello 1.6 # Set up tracing using the specified key.
92 :     ETracing($key);
93 : parrello 1.13 # Run this request.
94 :     RunRequest($cgi, $serverThing);
95 : parrello 1.6 }
96 : parrello 1.3 }
97 : parrello 1.1 }
98 : parrello 1.6 }
99 :    
100 :    
101 : parrello 1.9 =head2 Server Utility Methods
102 :    
103 :     The methods in this section are utilities of general use to the various
104 :     server modules.
105 :    
106 : parrello 1.21 =head3 AddSubsystemFilter
107 :    
108 :     ServerThing::AddSubsystemFilter(\$filter, $args);
109 :    
110 :     Add subsystem filtering information to the specified query filter clause
111 :     based on data in the argument hash. The argument hash will be checked for
112 :     the C<-unusable> parameter, which includes unusuable subsystems, and the
113 :     C<-exclude> parameter, which lists types of subsystems that should be
114 :     excluded.
115 :    
116 :     =over 4
117 :    
118 :     =item filter
119 :    
120 :     Reference to the current filter string. If additional filtering is required,
121 :     this string will be updated.
122 :    
123 :     =item args
124 :    
125 :     Reference to the parameter hash for the current server call. This hash will
126 :     be examined for the C<-unusable> and C<-exclude> parameters.
127 :    
128 :     =back
129 :    
130 :     =cut
131 :    
132 :     use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
133 :     experimental => 1,
134 :     private => 1 };
135 :    
136 :     sub AddSubsystemFilter {
137 :     # Get the parameters.
138 :     my ($filter, $args) = @_;
139 :     # We'll put the new filter stuff in here.
140 :     my @newFilters;
141 :     # Unless unusable subsystems are desired, we must add a clause to the filter.
142 :     if (! $args->{-unusable}) {
143 :     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 :     Trace("Subsystem filter is $$filter.") if T(3);
165 :     }
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.9 # Try to get the IDs from the argument structure.
204 :     my $retVal = $args->{$name};
205 : parrello 1.19 # Was a member found?
206 :     if (! defined $retVal) {
207 :     # No. If we're optional, return an empty list; otherwise throw an error.
208 :     if ($optional) {
209 :     $retVal = [];
210 :     } else {
211 :     Confess("No '$name' parameter found.");
212 :     }
213 :     } else {
214 :     # Here we found something. Get the parameter type. We was a list reference.
215 :     # If it's a scalar, we'll convert it to a singleton list. If it's anything
216 :     # else, it's an error.
217 :     my $type = ref $retVal;
218 :     if (! $type) {
219 :     $retVal = [$retVal];
220 :     } elsif ($type ne 'ARRAY') {
221 :     Confess("The '$name' parameter must be a list.");
222 :     }
223 : parrello 1.9 }
224 :     # Return the result.
225 :     return $retVal;
226 :     }
227 :    
228 :    
229 :     =head3 RunTool
230 :    
231 :     ServerThing::RunTool($name => $cmd);
232 :    
233 :     Run a command-line tool. A non-zero return value from the tool will cause
234 :     a fatal error, and the tool's error log will be traced.
235 :    
236 :     =over 4
237 :    
238 :     =item name
239 :    
240 :     Name to give to the tool in the error output.
241 :    
242 :     =item cmd
243 :    
244 :     Command to use for running the tool. This should be the complete command line.
245 :     The command should not contain any fancy piping, though it may redirect the
246 :     standard input and output. The command will be modified by this method to
247 :     redirect the error output to a temporary file.
248 :    
249 :     =back
250 :    
251 :     =cut
252 :    
253 :     sub RunTool {
254 :     # Get the parameters.
255 :     my ($name, $cmd) = @_;
256 :     # Compute the log file name.
257 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
258 :     # Execute the command.
259 :     Trace("Executing command: $cmd") if T(3);
260 :     my $res = system("$cmd 2> $errorLog");
261 :     Trace("Return from $name tool is $res.") if T(3);
262 :     # Check the result code.
263 :     if ($res != 0) {
264 :     # We have an error. If tracing is on, trace it.
265 :     if (T(1)) {
266 :     TraceErrorLog($name, $errorLog);
267 :     }
268 :     # Delete the error log.
269 :     unlink $errorLog;
270 :     # Confess the error.
271 : parrello 1.10 Confess("$name command failed with error code $res.");
272 : parrello 1.9 } else {
273 :     # Everything worked. Trace the error log if necessary.
274 :     if (T(3) && -s $errorLog) {
275 :     TraceErrorLog($name, $errorLog);
276 :     }
277 :     # Delete the error log if there is one.
278 :     unlink $errorLog;
279 :     }
280 :     }
281 :    
282 :    
283 :     =head2 Internal Utility Methods
284 :    
285 :     The methods in this section are used internally by this package.
286 :    
287 : parrello 1.6 =head3 RunRequest
288 :    
289 : parrello 1.9 ServerThing::RunRequest($cgi, $serverName);
290 : parrello 1.6
291 :     Run a request from the specified server using the incoming CGI parameter
292 :     object for the parameters.
293 :    
294 :     =over 4
295 :    
296 :     =item cgi
297 :    
298 :     CGI query object containing the parameters from the web service request.
299 :    
300 : parrello 1.13 =item serverThing
301 : parrello 1.6
302 : parrello 1.13 Server object against which to run the request.
303 : parrello 1.6
304 :     =back
305 :    
306 :     =cut
307 :    
308 :     sub RunRequest {
309 :     # Get the parameters.
310 : parrello 1.13 my ($cgi, $serverThing, $docURL) = @_;
311 : parrello 1.9 # Determine the request type.
312 :     if ($cgi->param('pod')) {
313 : parrello 1.4 # Here we have a documentation request. In this case, we produce POD HTML.
314 : parrello 1.9 ProducePod($cgi->param('pod'));
315 :     } elsif ($cgi->param('file')) {
316 :     # Here we have a file request. Process according to the type.
317 :     my $type = $cgi->param('file');
318 :     if ($type eq 'open') {
319 :     OpenFile($cgi->param('name'));
320 :     } elsif ($type eq 'create') {
321 :     CreateFile();
322 :     } elsif ($type eq 'read') {
323 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
324 :     } elsif ($type eq 'write') {
325 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
326 :     } else {
327 :     Die("Invalid file function \"$type\".");
328 : parrello 1.4 }
329 : parrello 1.1 } else {
330 : parrello 1.9 # The default is a function request. Get the function name.
331 : parrello 1.4 my $function = $cgi->param('function') || "";
332 : parrello 1.15 Trace("Server function for task $$ is $function.") if T(3);
333 : parrello 1.4 # Insure the function name is valid.
334 :     Die("Invalid function name.")
335 :     if $function =~ /\W/;
336 :     # The parameter structure will go in here.
337 :     my $args;
338 :     # Start the timer.
339 :     my $start = time();
340 :     # The output document goes in here.
341 :     my $document;
342 :     # The sapling database goes in here.
343 :     my $sapling;
344 :     # Protect from errors.
345 : parrello 1.1 eval {
346 : parrello 1.4 # Parse the arguments.
347 :     $args = YAML::Load($cgi->param('args'));
348 : parrello 1.1 };
349 : parrello 1.4 # Check to make sure we got everything.
350 : parrello 1.1 if ($@) {
351 : parrello 1.10 SendError($@, "Error formatting parameters.");
352 : parrello 1.4 } elsif (! $function) {
353 : parrello 1.10 SendError("No function specified.", "No function specified.");
354 : parrello 1.1 } else {
355 : parrello 1.13 $document = eval("\$serverThing->$function(\$args)");
356 : parrello 1.1 # If we have an error, create an error document.
357 :     if ($@) {
358 : parrello 1.13 SendError($@, "Error detected by service.");
359 :     Trace("Error encountered by service: $@") if T(2);
360 : parrello 1.1 } else {
361 : parrello 1.13 # No error, so we output the result.
362 :     print $cgi->header(-type => 'text/plain');
363 : parrello 1.18 my $string = YAML::Dump($document);
364 :     print $string;
365 :     MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
366 : parrello 1.1 }
367 :     }
368 : parrello 1.4 # Stop the timer.
369 :     my $duration = int(time() - $start + 0.5);
370 : parrello 1.15 Trace("Function executed in $duration seconds by task $$.") if T(2);
371 : parrello 1.1 }
372 :     }
373 :    
374 : parrello 1.9 =head3 CreateFile
375 :    
376 :     ServerThing::CreateFile();
377 :    
378 :     Create a new, empty temporary file and send its name back to the client.
379 :    
380 :     =cut
381 :    
382 :     sub CreateFile {
383 :     ##TODO: Code
384 :     }
385 :    
386 :     =head3 OpenFile
387 : parrello 1.6
388 : parrello 1.9 ServerThing::OpenFile($name);
389 : parrello 1.1
390 : parrello 1.9 Send the length of the named file back to the client.
391 :    
392 :     =over 4
393 :    
394 :     =item name
395 :    
396 :     ##TODO: name description
397 :    
398 :     =back
399 :    
400 :     =cut
401 :    
402 :     sub OpenFile {
403 :     # Get the parameters.
404 :     my ($name) = @_;
405 :     ##TODO: Code
406 :     }
407 : parrello 1.1
408 : parrello 1.9 =head3 ReadChunk
409 : parrello 1.1
410 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
411 : parrello 1.1
412 : parrello 1.9 Read the indicated number of bytes from the specified location of the
413 :     named file and send them back to the client.
414 : parrello 1.1
415 :     =over 4
416 :    
417 :     =item name
418 :    
419 : parrello 1.9 ##TODO: name description
420 : parrello 1.1
421 : parrello 1.9 =item location
422 : parrello 1.1
423 : parrello 1.9 ##TODO: location description
424 : parrello 1.1
425 : parrello 1.9 =item size
426 : parrello 1.1
427 : parrello 1.9 ##TODO: size description
428 : parrello 1.1
429 :     =back
430 :    
431 :     =cut
432 :    
433 : parrello 1.9 sub ReadChunk {
434 : parrello 1.1 # Get the parameters.
435 : parrello 1.9 my ($name, $location, $size) = @_;
436 :     ##TODO: Code
437 : parrello 1.1 }
438 :    
439 : parrello 1.9 =head3 WriteChunk
440 : parrello 1.1
441 : parrello 1.9 ServerThing::WriteChunk($name, $data);
442 : parrello 1.8
443 : parrello 1.9 Write the specified data to the named file.
444 : parrello 1.8
445 :     =over 4
446 :    
447 :     =item name
448 :    
449 : parrello 1.9 ##TODO: name description
450 :    
451 :     =item data
452 :    
453 :     ##TODO: data description
454 :    
455 :     =back
456 :    
457 :     =cut
458 :    
459 :     sub WriteChunk {
460 :     # Get the parameters.
461 :     my ($name, $data) = @_;
462 :     ##TODO: Code
463 :     }
464 :    
465 :    
466 :     =head3 ProducePod
467 :    
468 :     ServerThing::ProducePod($module);
469 :    
470 :     Output the POD documentation for the specified module.
471 :    
472 :     =over 4
473 : parrello 1.8
474 : parrello 1.9 =item module
475 : parrello 1.8
476 : parrello 1.9 Name of the module whose POD document is to be displayed.
477 : parrello 1.8
478 :     =back
479 :    
480 :     =cut
481 :    
482 : parrello 1.9 sub ProducePod {
483 : parrello 1.8 # Get the parameters.
484 : parrello 1.9 my ($module) = @_;
485 :     # Start the output page.
486 :     print CGI::header();
487 :     print CGI::start_html(-title => 'Documentation Page',
488 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
489 :     # Protect from errors.
490 :     eval {
491 :     # We'll format the HTML text in here.
492 :     require DocUtils;
493 : parrello 1.20 my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
494 : parrello 1.9 # Output the POD HTML.
495 :     print $html;
496 :     };
497 :     # Process any error.
498 :     if ($@) {
499 :     print CGI::blockquote({ class => 'error' }, $@);
500 : parrello 1.8 }
501 : parrello 1.9 # Close off the page.
502 :     print CGI::end_html();
503 :    
504 : parrello 1.8 }
505 :    
506 :     =head3 TraceErrorLog
507 :    
508 :     ServerThing::TraceErrorLog($name, $errorLog);
509 :    
510 :     Trace the specified error log file. This is a very dinky routine that
511 :     performs a task required by L</RunTool> in multiple places.
512 :    
513 :     =over 4
514 :    
515 :     =item name
516 :    
517 :     Name of the tool relevant to the log file.
518 :    
519 :     =item errorLog
520 :    
521 :     Name of the log file.
522 :    
523 :     =back
524 :    
525 :     =cut
526 :    
527 :     sub TraceErrorLog {
528 :     my ($name, $errorLog) = @_;
529 :     my $errorData = Tracer::GetFile($errorLog);
530 :     Trace("$name error log:\n$errorData");
531 :     }
532 :    
533 : parrello 1.10 =head3 SendError
534 :    
535 :     ServerThing::SendError($message, $status);
536 :    
537 :     Fail an HTTP request with the specified error message and the specified
538 :     status message.
539 :    
540 :     =over 4
541 :    
542 :     =item message
543 :    
544 :     Detailed error message. This is sent as the page content.
545 :    
546 :     =item status
547 :    
548 :     Status message. This is sent as part of the status code.
549 :    
550 :     =back
551 :    
552 :     =cut
553 :    
554 :     sub SendError {
555 :     # Get the parameters.
556 :     my ($message, $status) = @_;
557 :     Trace("Error \"$status\" $message") if T(2);
558 :     # Print the header and the status message.
559 :     print CGI::header(-type => 'text/plain',
560 :     -status => "500 $status");
561 :     # Print the detailed message.
562 :     print $message;
563 :     }
564 :    
565 :    
566 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3