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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3