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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (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 :     use constant MAX_REQUESTS => 5000;
18 :    
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.1 # Get the CGI parameters.
36 :     my $cgi;
37 : parrello 1.6 if (! defined $key) {
38 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
39 :     if ($ENV{REQUEST_METHOD} eq '') {
40 :     # Here we're doing Fast CGI. In this case, the tracing key is the
41 :     # server name.
42 :     ETracing($serverName);
43 : parrello 1.11 # Count the number of requests.
44 :     my $requests = 0;
45 :     # Loop through the fast CGI requests. If we have request throttling,
46 :     # we exit after a maximum number of requests has been exceeded.
47 : parrello 1.6 require CGI::Fast;
48 : parrello 1.11 while ($cgi = new CGI::Fast() &&
49 :     (MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS)) {
50 : parrello 1.9 RunRequest($cgi, $serverName);
51 : parrello 1.6 }
52 : parrello 1.3 } else {
53 : parrello 1.6 # Here we have a normal web service (non-Fast).
54 :     my $cgi = CGI->new();
55 :     # Check for a source parameter. This gets used as the tracing key.
56 :     $key = $cgi->param('source');
57 :     if (! $key) {
58 :     # No source parameter, so do normal setup. Note we turn off
59 :     # CGI parameter tracing.
60 :     ETracing($cgi, 'noParms');
61 :     } else {
62 :     # Set up tracing using the specified key.
63 :     ETracing($key);
64 :     }
65 :     # Run this request.
66 : parrello 1.9 RunRequest($cgi, $serverName);
67 : parrello 1.3 }
68 : parrello 1.1 } else {
69 :     # We're being invoked from the command line. Use the tracing
70 :     # key to find the parm file and create the CGI object from that.
71 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
72 :     $cgi = CGI->new($ih);
73 :     # Set up tracing using the specified key.
74 :     ETracing($key);
75 : parrello 1.6 # Run this request.
76 : parrello 1.9 RunRequest($cgi, $serverName);
77 : parrello 1.1 }
78 : parrello 1.6 }
79 :    
80 :    
81 : parrello 1.9 =head2 Server Utility Methods
82 :    
83 :     The methods in this section are utilities of general use to the various
84 :     server modules.
85 :    
86 :     =head3 GetIdList
87 :    
88 :     my $ids = ServerThing::GetIdList($name => $args);
89 :    
90 :     Get a named list of IDs from an argument structure. If the IDs are
91 :     missing, or are not a list, an error will occur.
92 :    
93 :     =over 4
94 :    
95 :     =item name
96 :    
97 :     Name of the argument structure member that should contain the ID list.
98 :    
99 :     =item args
100 :    
101 :     Argument structure from which the ID list is to be extracted.
102 :    
103 :     =item RETURN
104 :    
105 :     Returns a reference to a list of IDs taken from the argument structure.
106 :    
107 :     =back
108 :    
109 :     =cut
110 :    
111 :     sub GetIdList {
112 :     # Get the parameters.
113 :     my ($name, $args) = @_;
114 :     # Try to get the IDs from the argument structure.
115 :     my $retVal = $args->{$name};
116 :     # Throw an error if no member was found.
117 :     Confess("No '$name' parameter found.") if ! defined $retVal;
118 :     # Get the parameter type. We was a list reference. If it's a scalar, we'll
119 :     # convert it to a singleton list. If it's anything else, it's an error.
120 :     my $type = ref $retVal;
121 :     if (! $type) {
122 :     $retVal = [$retVal];
123 :     } elsif ($type ne 'ARRAY') {
124 :     Confess("The '$name' parameter must be a list.");
125 :     }
126 :     # Return the result.
127 :     return $retVal;
128 :     }
129 :    
130 :    
131 :     =head3 RunTool
132 :    
133 :     ServerThing::RunTool($name => $cmd);
134 :    
135 :     Run a command-line tool. A non-zero return value from the tool will cause
136 :     a fatal error, and the tool's error log will be traced.
137 :    
138 :     =over 4
139 :    
140 :     =item name
141 :    
142 :     Name to give to the tool in the error output.
143 :    
144 :     =item cmd
145 :    
146 :     Command to use for running the tool. This should be the complete command line.
147 :     The command should not contain any fancy piping, though it may redirect the
148 :     standard input and output. The command will be modified by this method to
149 :     redirect the error output to a temporary file.
150 :    
151 :     =back
152 :    
153 :     =cut
154 :    
155 :     sub RunTool {
156 :     # Get the parameters.
157 :     my ($name, $cmd) = @_;
158 :     # Compute the log file name.
159 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
160 :     # Execute the command.
161 :     Trace("Executing command: $cmd") if T(3);
162 :     my $res = system("$cmd 2> $errorLog");
163 :     Trace("Return from $name tool is $res.") if T(3);
164 :     # Check the result code.
165 :     if ($res != 0) {
166 :     # We have an error. If tracing is on, trace it.
167 :     if (T(1)) {
168 :     TraceErrorLog($name, $errorLog);
169 :     }
170 :     # Delete the error log.
171 :     unlink $errorLog;
172 :     # Confess the error.
173 : parrello 1.10 Confess("$name command failed with error code $res.");
174 : parrello 1.9 } else {
175 :     # Everything worked. Trace the error log if necessary.
176 :     if (T(3) && -s $errorLog) {
177 :     TraceErrorLog($name, $errorLog);
178 :     }
179 :     # Delete the error log if there is one.
180 :     unlink $errorLog;
181 :     }
182 :     }
183 :    
184 :    
185 :     =head2 Internal Utility Methods
186 :    
187 :     The methods in this section are used internally by this package.
188 :    
189 : parrello 1.6 =head3 RunRequest
190 :    
191 : parrello 1.9 ServerThing::RunRequest($cgi, $serverName);
192 : parrello 1.6
193 :     Run a request from the specified server using the incoming CGI parameter
194 :     object for the parameters.
195 :    
196 :     =over 4
197 :    
198 :     =item cgi
199 :    
200 :     CGI query object containing the parameters from the web service request.
201 :    
202 :     =item serverName
203 :    
204 :     Name of the server to be used for running the request.
205 :    
206 :     =back
207 :    
208 :     =cut
209 :    
210 :     sub RunRequest {
211 :     # Get the parameters.
212 :     my ($cgi, $serverName, $docURL) = @_;
213 : parrello 1.1 Trace("Running $serverName server request.") if T(3);
214 : parrello 1.9 # Determine the request type.
215 :     if ($cgi->param('pod')) {
216 : parrello 1.4 # Here we have a documentation request. In this case, we produce POD HTML.
217 : parrello 1.9 ProducePod($cgi->param('pod'));
218 :     } elsif ($cgi->param('file')) {
219 :     # Here we have a file request. Process according to the type.
220 :     my $type = $cgi->param('file');
221 :     if ($type eq 'open') {
222 :     OpenFile($cgi->param('name'));
223 :     } elsif ($type eq 'create') {
224 :     CreateFile();
225 :     } elsif ($type eq 'read') {
226 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
227 :     } elsif ($type eq 'write') {
228 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
229 :     } else {
230 :     Die("Invalid file function \"$type\".");
231 : parrello 1.4 }
232 : parrello 1.1 } else {
233 : parrello 1.9 # The default is a function request. Get the function name.
234 : parrello 1.4 my $function = $cgi->param('function') || "";
235 :     Trace("Server function is $function.") if T(3);
236 :     # Insure the function name is valid.
237 :     Die("Invalid function name.")
238 :     if $function =~ /\W/;
239 :     # The parameter structure will go in here.
240 :     my $args;
241 :     # Start the timer.
242 :     my $start = time();
243 :     # The output document goes in here.
244 :     my $document;
245 :     # The sapling database goes in here.
246 :     my $sapling;
247 :     # Protect from errors.
248 : parrello 1.1 eval {
249 : parrello 1.4 # Parse the arguments.
250 :     $args = YAML::Load($cgi->param('args'));
251 : parrello 1.1 };
252 : parrello 1.4 # Check to make sure we got everything.
253 : parrello 1.1 if ($@) {
254 : parrello 1.10 SendError($@, "Error formatting parameters.");
255 : parrello 1.4 } elsif (! $function) {
256 : parrello 1.10 SendError("No function specified.", "No function specified.");
257 : parrello 1.1 } else {
258 : parrello 1.4 # We're okay, so load the server function object.
259 :     Trace("Requiring $serverName") if T(3);
260 :     eval {
261 :     require "$serverName.pm";
262 :     };
263 : parrello 1.1 # If we have an error, create an error document.
264 :     if ($@) {
265 : parrello 1.10 SendError($function, $@, "Could not load server module.");
266 : parrello 1.1 } else {
267 : parrello 1.4 # Having successfully loaded the server code, we create the object.
268 :     my $serverThing = eval("$serverName" . '->new()');
269 : parrello 1.1 # If we have an error, create an error document.
270 :     if ($@) {
271 : parrello 1.10 SendError($@, "Could not start server.");
272 : parrello 1.4 } else {
273 :     # No error, so execute the server method.
274 :     Trace("Executing $function.") if T(2);
275 :     $document = eval("\$serverThing->$function(\$args)");
276 :     # If we have an error, create an error document.
277 :     if ($@) {
278 : parrello 1.10 SendError($@, "Error detected by service.");
279 : parrello 1.4 Trace("Error encountered by service: $@") if T(2);
280 : parrello 1.10 } else {
281 :     # No error, so we output the result.
282 :     print $cgi->header(-type => 'text/plain');
283 :     print YAML::Dump($document);
284 : parrello 1.4 }
285 : parrello 1.1 }
286 :     }
287 :     }
288 : parrello 1.4 # Stop the timer.
289 :     my $duration = int(time() - $start + 0.5);
290 :     Trace("Function executed in $duration seconds.") if T(2);
291 : parrello 1.1 }
292 :     }
293 :    
294 : parrello 1.9 =head3 CreateFile
295 :    
296 :     ServerThing::CreateFile();
297 :    
298 :     Create a new, empty temporary file and send its name back to the client.
299 :    
300 :     =cut
301 :    
302 :     sub CreateFile {
303 :     ##TODO: Code
304 :     }
305 :    
306 :     =head3 OpenFile
307 : parrello 1.6
308 : parrello 1.9 ServerThing::OpenFile($name);
309 : parrello 1.1
310 : parrello 1.9 Send the length of the named file back to the client.
311 :    
312 :     =over 4
313 :    
314 :     =item name
315 :    
316 :     ##TODO: name description
317 :    
318 :     =back
319 :    
320 :     =cut
321 :    
322 :     sub OpenFile {
323 :     # Get the parameters.
324 :     my ($name) = @_;
325 :     ##TODO: Code
326 :     }
327 : parrello 1.1
328 : parrello 1.9 =head3 ReadChunk
329 : parrello 1.1
330 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
331 : parrello 1.1
332 : parrello 1.9 Read the indicated number of bytes from the specified location of the
333 :     named file and send them back to the client.
334 : parrello 1.1
335 :     =over 4
336 :    
337 :     =item name
338 :    
339 : parrello 1.9 ##TODO: name description
340 : parrello 1.1
341 : parrello 1.9 =item location
342 : parrello 1.1
343 : parrello 1.9 ##TODO: location description
344 : parrello 1.1
345 : parrello 1.9 =item size
346 : parrello 1.1
347 : parrello 1.9 ##TODO: size description
348 : parrello 1.1
349 :     =back
350 :    
351 :     =cut
352 :    
353 : parrello 1.9 sub ReadChunk {
354 : parrello 1.1 # Get the parameters.
355 : parrello 1.9 my ($name, $location, $size) = @_;
356 :     ##TODO: Code
357 : parrello 1.1 }
358 :    
359 : parrello 1.9 =head3 WriteChunk
360 : parrello 1.1
361 : parrello 1.9 ServerThing::WriteChunk($name, $data);
362 : parrello 1.8
363 : parrello 1.9 Write the specified data to the named file.
364 : parrello 1.8
365 :     =over 4
366 :    
367 :     =item name
368 :    
369 : parrello 1.9 ##TODO: name description
370 :    
371 :     =item data
372 :    
373 :     ##TODO: data description
374 :    
375 :     =back
376 :    
377 :     =cut
378 :    
379 :     sub WriteChunk {
380 :     # Get the parameters.
381 :     my ($name, $data) = @_;
382 :     ##TODO: Code
383 :     }
384 :    
385 :    
386 :     =head3 ProducePod
387 :    
388 :     ServerThing::ProducePod($module);
389 :    
390 :     Output the POD documentation for the specified module.
391 :    
392 :     =over 4
393 : parrello 1.8
394 : parrello 1.9 =item module
395 : parrello 1.8
396 : parrello 1.9 Name of the module whose POD document is to be displayed.
397 : parrello 1.8
398 :     =back
399 :    
400 :     =cut
401 :    
402 : parrello 1.9 sub ProducePod {
403 : parrello 1.8 # Get the parameters.
404 : parrello 1.9 my ($module) = @_;
405 :     # Start the output page.
406 :     print CGI::header();
407 :     print CGI::start_html(-title => 'Documentation Page',
408 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
409 :     # Protect from errors.
410 :     eval {
411 :     # We'll format the HTML text in here.
412 :     require DocUtils;
413 :     my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/servers.cgi?pod=");
414 :     # Output the POD HTML.
415 :     print $html;
416 :     };
417 :     # Process any error.
418 :     if ($@) {
419 :     print CGI::blockquote({ class => 'error' }, $@);
420 : parrello 1.8 }
421 : parrello 1.9 # Close off the page.
422 :     print CGI::end_html();
423 :    
424 : parrello 1.8 }
425 :    
426 :     =head3 TraceErrorLog
427 :    
428 :     ServerThing::TraceErrorLog($name, $errorLog);
429 :    
430 :     Trace the specified error log file. This is a very dinky routine that
431 :     performs a task required by L</RunTool> in multiple places.
432 :    
433 :     =over 4
434 :    
435 :     =item name
436 :    
437 :     Name of the tool relevant to the log file.
438 :    
439 :     =item errorLog
440 :    
441 :     Name of the log file.
442 :    
443 :     =back
444 :    
445 :     =cut
446 :    
447 :     sub TraceErrorLog {
448 :     my ($name, $errorLog) = @_;
449 :     my $errorData = Tracer::GetFile($errorLog);
450 :     Trace("$name error log:\n$errorData");
451 :     }
452 :    
453 : parrello 1.10 =head3 SendError
454 :    
455 :     ServerThing::SendError($message, $status);
456 :    
457 :     Fail an HTTP request with the specified error message and the specified
458 :     status message.
459 :    
460 :     =over 4
461 :    
462 :     =item message
463 :    
464 :     Detailed error message. This is sent as the page content.
465 :    
466 :     =item status
467 :    
468 :     Status message. This is sent as part of the status code.
469 :    
470 :     =back
471 :    
472 :     =cut
473 :    
474 :     sub SendError {
475 :     # Get the parameters.
476 :     my ($message, $status) = @_;
477 :     Trace("Error \"$status\" $message") if T(2);
478 :     # Print the header and the status message.
479 :     print CGI::header(-type => 'text/plain',
480 :     -status => "500 $status");
481 :     # Print the detailed message.
482 :     print $message;
483 :     }
484 :    
485 :    
486 : parrello 1.8
487 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3