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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3