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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (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 :     use ErrorDocument;
12 :     use CGI;
13 :    
14 :     =head1 General Server Helper
15 :    
16 :     This package provides a method-- I<RunServer>-- that can be called from a CGI
17 : parrello 1.5 script to perform the duties of a FIG server. RunServer is called with three
18 :     parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>),
19 :     the first command-line parameter, and the URL prefix to use for the documentation.
20 :     The command-line parameter (if defined) will be used as the tracing key, and is
21 :     used to indicate that the script is being invoked from the command line rather
22 :     than over the web.
23 : parrello 1.1
24 :     =cut
25 :    
26 :     sub RunServer {
27 :     # Get the parameters.
28 : parrello 1.5 my ($serverName, $key, $docURL) = @_;
29 : parrello 1.1 # Get the CGI parameters.
30 :     my $cgi;
31 : parrello 1.6 if (! defined $key) {
32 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
33 :     if ($ENV{REQUEST_METHOD} eq '') {
34 :     # Here we're doing Fast CGI. In this case, the tracing key is the
35 :     # server name.
36 :     ETracing($serverName);
37 :     # Loop through the fast CGI requests.
38 :     require CGI::Fast;
39 :     while ($cgi = new CGI::Fast()) {
40 :     RunRequest($cgi, $serverName, $docURL);
41 :     }
42 : parrello 1.3 } else {
43 : parrello 1.6 # Here we have a normal web service (non-Fast).
44 :     my $cgi = CGI->new();
45 :     # Check for a source parameter. This gets used as the tracing key.
46 :     $key = $cgi->param('source');
47 :     if (! $key) {
48 :     # No source parameter, so do normal setup. Note we turn off
49 :     # CGI parameter tracing.
50 :     ETracing($cgi, 'noParms');
51 :     } else {
52 :     # Set up tracing using the specified key.
53 :     ETracing($key);
54 :     }
55 :     # Run this request.
56 :     RunRequest($cgi, $serverName, $docURL);
57 : parrello 1.3 }
58 : parrello 1.1 } else {
59 :     # We're being invoked from the command line. Use the tracing
60 :     # key to find the parm file and create the CGI object from that.
61 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
62 :     $cgi = CGI->new($ih);
63 :     # Set up tracing using the specified key.
64 :     ETracing($key);
65 : parrello 1.6 # Run this request.
66 :     RunRequest($cgi, $serverName, $docURL);
67 : parrello 1.1 }
68 : parrello 1.6 }
69 :    
70 :    
71 :     =head3 RunRequest
72 :    
73 :     ServerThing::RunRequest($cgi, $serverName, $docURL);
74 :    
75 :     Run a request from the specified server using the incoming CGI parameter
76 :     object for the parameters.
77 :    
78 :     =over 4
79 :    
80 :     =item cgi
81 :    
82 :     CGI query object containing the parameters from the web service request.
83 :    
84 :     =item serverName
85 :    
86 :     Name of the server to be used for running the request.
87 :    
88 :     =item docURL
89 :    
90 :     URL to be used for a documentation request.
91 :    
92 :     =back
93 :    
94 :     =cut
95 :    
96 :     sub RunRequest {
97 :     # Get the parameters.
98 :     my ($cgi, $serverName, $docURL) = @_;
99 : parrello 1.1 Trace("Running $serverName server request.") if T(3);
100 : parrello 1.4 # Is this a documentation request?
101 :     my $module = $cgi->param('pod');
102 :     if ($module) {
103 :     # Here we have a documentation request. In this case, we produce POD HTML.
104 :     # Start the output page.
105 :     print CGI::header();
106 :     print CGI::start_html(-title => 'Documentation Page',
107 : parrello 1.7 -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
108 : parrello 1.4 # Protect from errors.
109 :     eval {
110 :     # We'll format the HTML text in here.
111 : parrello 1.8 require DocUtils;
112 : parrello 1.5 my $html = DocUtils::ShowPod($module, $docURL);
113 : parrello 1.4 # Output the POD HTML.
114 :     print $html;
115 :     };
116 :     # Process any error.
117 :     if ($@) {
118 :     print CGI::blockquote({ class => 'error' }, $@);
119 :     }
120 :     # Close off the page.
121 :     print CGI::end_html();
122 : parrello 1.1 } else {
123 : parrello 1.4 # Here we have a function request. Get the function name.
124 :     my $function = $cgi->param('function') || "";
125 :     Trace("Server function is $function.") if T(3);
126 :     # Insure the function name is valid.
127 :     Die("Invalid function name.")
128 :     if $function =~ /\W/;
129 :     # The parameter structure will go in here.
130 :     my $args;
131 :     # Start the timer.
132 :     my $start = time();
133 :     # The output document goes in here.
134 :     my $document;
135 :     # The sapling database goes in here.
136 :     my $sapling;
137 :     # Protect from errors.
138 : parrello 1.1 eval {
139 : parrello 1.4 # Parse the arguments.
140 :     $args = YAML::Load($cgi->param('args'));
141 : parrello 1.1 };
142 : parrello 1.4 # Check to make sure we got everything.
143 : parrello 1.1 if ($@) {
144 : parrello 1.4 $document = ErrorDocument->new('<initialization>', $@);
145 :     } elsif (! $function) {
146 :     $document = ErrorDocument->new('<missing>', "No function specified.");
147 : parrello 1.1 } else {
148 : parrello 1.4 # We're okay, so load the server function object.
149 :     Trace("Requiring $serverName") if T(3);
150 :     eval {
151 :     require "$serverName.pm";
152 :     };
153 : parrello 1.1 # If we have an error, create an error document.
154 :     if ($@) {
155 :     $document = ErrorDocument->new($function, $@);
156 : parrello 1.6 Trace("Error loading server module: $@") if T(2);
157 : parrello 1.1 } else {
158 : parrello 1.4 # Having successfully loaded the server code, we create the object.
159 :     my $serverThing = eval("$serverName" . '->new()');
160 : parrello 1.1 # If we have an error, create an error document.
161 :     if ($@) {
162 :     $document = ErrorDocument->new($function, $@);
163 : parrello 1.4 Trace("Error creating server function object: $@") if T(2);
164 :     } else {
165 :     # No error, so execute the server method.
166 :     Trace("Executing $function.") if T(2);
167 :     $document = eval("\$serverThing->$function(\$args)");
168 :     # If we have an error, create an error document.
169 :     if ($@) {
170 :     $document = ErrorDocument->new($function, $@);
171 :     Trace("Error encountered by service: $@") if T(2);
172 :     }
173 : parrello 1.1 }
174 :     }
175 :     }
176 : parrello 1.4 # Stop the timer.
177 :     my $duration = int(time() - $start + 0.5);
178 :     Trace("Function executed in $duration seconds.") if T(2);
179 :     # Output the YAML.
180 :     print $cgi->header(-type => 'text/plain');
181 :     print YAML::Dump($document);
182 : parrello 1.1 }
183 :     }
184 :    
185 : parrello 1.6
186 : parrello 1.1 =head2 Utility Methods
187 :    
188 :     The methods in this section are utilities of general use to the various
189 :     server modules.
190 :    
191 :     =head3 GetIdList
192 :    
193 :     my $ids = ServerThing::GetIdList($name => $args);
194 :    
195 :     Get a named list of IDs from an argument structure. If the IDs are
196 :     missing, or are not a list, an error will occur.
197 :    
198 :     =over 4
199 :    
200 :     =item name
201 :    
202 :     Name of the argument structure member that should contain the ID list.
203 :    
204 :     =item args
205 :    
206 :     Argument structure from which the ID list is to be extracted.
207 :    
208 :     =item RETURN
209 :    
210 :     Returns a reference to a list of IDs taken from the argument structure.
211 :    
212 :     =back
213 :    
214 :     =cut
215 :    
216 :     sub GetIdList {
217 :     # Get the parameters.
218 :     my ($name, $args) = @_;
219 :     # Try to get the IDs from the argument structure.
220 :     my $retVal = $args->{$name};
221 :     # Throw an error if no member was found.
222 :     Confess("No '$name' parameter found.") if ! defined $retVal;
223 :     # Get the parameter type. We was a list reference. If it's a scalar, we'll
224 :     # convert it to a singleton list. If it's anything else, it's an error.
225 :     my $type = ref $retVal;
226 :     if (! $type) {
227 :     $retVal = [$retVal];
228 :     } elsif ($type ne 'ARRAY') {
229 :     Confess("The '$name' parameter must be a list.");
230 :     }
231 :     # Return the result.
232 :     return $retVal;
233 :     }
234 :    
235 :    
236 : parrello 1.8 =head3 RunTool
237 :    
238 :     ServerThing::RunTool($name => $cmd);
239 :    
240 :     Run a command-line tool. A non-zero return value from the tool will cause
241 :     a fatal error, and the tool's error log will be traced.
242 :    
243 :     =over 4
244 :    
245 :     =item name
246 :    
247 :     Name to give to the tool in the error output.
248 :    
249 :     =item cmd
250 :    
251 :     Command to use for running the tool. This should be the complete command line.
252 :     The command should not contain any fancy piping, though it may redirect the
253 :     standard input and output. The command will be modified by this method to
254 :     redirect the error output to a temporary file.
255 :    
256 :     =back
257 :    
258 :     =cut
259 :    
260 :     sub RunTool {
261 :     # Get the parameters.
262 :     my ($name, $cmd) = @_;
263 :     # Compute the log file name.
264 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
265 :     # Execute the command.
266 :     Trace("Executing command: $cmd") if T(3);
267 :     my $res = system("$cmd 2> $errorLog");
268 :     Trace("Return from $name tool is $res.") if T(3);
269 :     # Check the result code.
270 :     if ($res != 0) {
271 :     # We have an error. If tracing is on, trace it.
272 :     if (T(1)) {
273 :     TraceErrorLog($name, $errorLog);
274 :     }
275 :     # Delete the error log.
276 :     unlink $errorLog;
277 :     # Confess the error.
278 :     Confess("500 $name command failed with error code $res.");
279 :     } else {
280 :     # Everything worked. Trace the error log if necessary.
281 :     if (T(3) && -s $errorLog) {
282 :     TraceErrorLog($name, $errorLog);
283 :     }
284 :     # Delete the error log if there is one.
285 :     unlink $errorLog;
286 :     }
287 :     }
288 :    
289 :     =head3 TraceErrorLog
290 :    
291 :     ServerThing::TraceErrorLog($name, $errorLog);
292 :    
293 :     Trace the specified error log file. This is a very dinky routine that
294 :     performs a task required by L</RunTool> in multiple places.
295 :    
296 :     =over 4
297 :    
298 :     =item name
299 :    
300 :     Name of the tool relevant to the log file.
301 :    
302 :     =item errorLog
303 :    
304 :     Name of the log file.
305 :    
306 :     =back
307 :    
308 :     =cut
309 :    
310 :     sub TraceErrorLog {
311 :     my ($name, $errorLog) = @_;
312 :     my $errorData = Tracer::GetFile($errorLog);
313 :     Trace("$name error log:\n$errorData");
314 :     }
315 :    
316 :    
317 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3