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

Diff of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5, Tue Aug 4 18:41:56 2009 UTC revision 1.51, Wed Apr 28 15:46:38 2010 UTC
# Line 5  Line 5 
5      use strict;      use strict;
6      use Tracer;      use Tracer;
7      use YAML;      use YAML;
8        use JSON::Any;
9      use ERDB;      use ERDB;
10      use TestUtils;      use TestUtils;
     use DocUtils;  
11      use Time::HiRes;      use Time::HiRes;
12      use ErrorDocument;      use File::Temp;
13        use ErrorMessage;
14      use CGI;      use CGI;
15        no warnings qw(once);
16    
17        # Maximum number of requests to run per invocation.
18        use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
22  This package provides a method-- I<RunServer>-- that can be called from a CGI  This package provides a method-- I<RunServer>-- that can be called from a CGI
23  script to perform the duties of a FIG server. RunServer is called with three  script to perform the duties of a FIG server. RunServer is called with two
24  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>),  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
25  the first command-line parameter, and the URL prefix to use for the documentation.  the first command-line parameter. The command-line parameter (if defined) will
26  The command-line parameter (if defined) will be used as the tracing key, and is  be used as the tracing key, and also indicates that the script is being invoked
27  used to indicate that the script is being invoked from the command line rather  from the command line rather than over the web.
 than over the web.  
28    
29  =cut  =cut
30    
31  sub RunServer {  sub RunServer {
32      # Get the parameters.      # Get the parameters.
33      my ($serverName, $key, $docURL) = @_;      my ($serverName, $key) = @_;
34      # Get the CGI parameters.      # Set up tracing. We never do CGI tracing here; the only question is whether
35      my $cgi;      # or not the caller passed in a tracing key. If he didn't, we use the server
36      if (! $key) {      # name.
37          # No tracing key, so presume we're a web service.      ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
38          $cgi = CGI->new();      # Turn off YAML compression, which causes problems with some of our hash keys.
39          # Check for a source parameter. This gets used as the tracing key.      $YAML::CompressSeries = 0;
40          $key = $cgi->param('source');      # Create the server object.
41          if (! $key) {      Trace("Requiring $serverName for task $$.") if T(3);
             # No source parameter, so do normal setup.  
             ETracing($cgi);  
         } else {  
             # Set up tracing using the specified key.  
             ETracing($key);  
             # Trace the CGI parameters.  
             Tracer::TraceParms($cgi);  
         }  
     } else {  
         # We're being invoked from the command line. Use the tracing  
         # key to find the parm file and create the CGI object from that.  
         my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");  
         $cgi = CGI->new($ih);  
         # Set up tracing using the specified key.  
         ETracing($key);  
         # Trace the CGI parameters.  
         Tracer::TraceParms($cgi);  
     }  
     Trace("Running $serverName server request.") if T(3);  
     # Is this a documentation request?  
     my $module = $cgi->param('pod');  
     if ($module) {  
         # Here we have a documentation request. In this case, we produce POD HTML.  
         # Start the output page.  
         print CGI::header();  
         print CGI::start_html(-title => 'Documentation Page',  
                               -style => { src => "$FIG_Config::cgi_url/Html/css/ERDB.css" });  
         # Protect from errors.  
         eval {  
             # We'll format the HTML text in here.  
             my $html = DocUtils::ShowPod($module, $docURL);  
             # Output the POD HTML.  
             print $html;  
         };  
         # Process any error.  
         if ($@) {  
             print CGI::blockquote({ class => 'error' }, $@);  
         }  
         # Close off the page.  
         print CGI::end_html();  
     } else {  
         # Here we have a function request. Get the function name.  
         my $function = $cgi->param('function') || "";  
         Trace("Server function is $function.") if T(3);  
         # Insure the function name is valid.  
         Die("Invalid function name.")  
             if $function =~ /\W/;  
         # The parameter structure will go in here.  
         my $args;  
         # Start the timer.  
         my $start = time();  
         # The output document goes in here.  
         my $document;  
         # The sapling database goes in here.  
         my $sapling;  
         # Protect from errors.  
         eval {  
             # Parse the arguments.  
             $args = YAML::Load($cgi->param('args'));  
         };  
         # Check to make sure we got everything.  
         if ($@) {  
             $document = ErrorDocument->new('<initialization>', $@);  
         } elsif (! $function) {  
             $document = ErrorDocument->new('<missing>', "No function specified.");  
         } else {  
             # We're okay, so load the server function object.  
             Trace("Requiring $serverName") if T(3);  
42              eval {              eval {
43                  require "$serverName.pm";                  require "$serverName.pm";
44              };              };
45              # If we have an error, create an error document.              # If we have an error, create an error document.
46              if ($@) {              if ($@) {
47                  $document = ErrorDocument->new($function, $@);          SendError($@, "Could not load server module.");
                 Trace("Error loadin server module: $@") if T(2);  
48              } else {              } else {
49                  # Having successfully loaded the server code, we create the object.                  # Having successfully loaded the server code, we create the object.
50                  my $serverThing = eval("$serverName" . '->new()');                  my $serverThing = eval("$serverName" . '->new()');
51            Trace("$serverName object created for task $$.") if T(2);
52                  # If we have an error, create an error document.                  # If we have an error, create an error document.
53                  if ($@) {                  if ($@) {
54                      $document = ErrorDocument->new($function, $@);              SendError($@, "Could not start server.");
                     Trace("Error creating server function object: $@") if T(2);  
55                  } else {                  } else {
56                      # No error, so execute the server method.              # No error, so now we can process the request.
57                      Trace("Executing $function.") if T(2);              my $cgi;
58                      $document = eval("\$serverThing->$function(\$args)");              if (! defined $key) {
59                      # If we have an error, create an error document.                  # No tracing key, so presume we're a web service. Check for Fast CGI.
60                      if ($@) {                  if ($ENV{REQUEST_METHOD} eq '') {
61                          $document = ErrorDocument->new($function, $@);                      # Count the number of requests.
62                          Trace("Error encountered by service: $@") if T(2);                      my $requests = 0;
63                        Trace("Starting Fast CGI loop.") if T(3);
64                        # Loop through the fast CGI requests. If we have request throttling,
65                        # we exit after a maximum number of requests has been exceeded.
66                        require CGI::Fast;
67                        while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
68                               ($cgi = new CGI::Fast())) {
69                            RunRequest($cgi, $serverThing);
70                            Trace("Request $requests complete in task $$.") if T(3);
71                      }                      }
72                        Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
73                    } else {
74                        # Here we have a normal web service (non-Fast).
75                        my $cgi = CGI->new();
76                        # Check for a source parameter. This gets used as the tracing key.
77                        $key = $cgi->param('source');
78                        # Run this request.
79                        RunRequest($cgi, $serverThing);
80                  }                  }
81                } else {
82                    # We're being invoked from the command line. Use the tracing
83                    # key to find the parm file and create the CGI object from that.
84                    my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
85                    $cgi = CGI->new($ih);
86                    # Run this request.
87                    RunRequest($cgi, $serverThing);
88              }              }
89          }          }
         # Stop the timer.  
         my $duration = int(time() - $start + 0.5);  
         Trace("Function executed in $duration seconds.") if T(2);  
         # Output the YAML.  
         print $cgi->header(-type => 'text/plain');  
         print YAML::Dump($document);  
90      }      }
91  }  }
92    
93  =head2 Utility Methods  
94    =head2 Server Utility Methods
95    
96  The methods in this section are utilities of general use to the various  The methods in this section are utilities of general use to the various
97  server modules.  server modules.
98    
99    =head3 AddSubsystemFilter
100    
101        ServerThing::AddSubsystemFilter(\$filter, $args);
102    
103    Add subsystem filtering information to the specified query filter clause
104    based on data in the argument hash. The argument hash will be checked for
105    the C<-usable> parameter, which includes or excludes unusuable subsystems, and
106    the C<-exclude> parameter, which lists types of subsystems that should be
107    excluded.
108    
109    =over 4
110    
111    =item filter
112    
113    Reference to the current filter string. If additional filtering is required,
114    this string will be updated.
115    
116    =item args
117    
118    Reference to the parameter hash for the current server call. This hash will
119    be examined for the C<-usable> and C<-exclude> parameters.
120    
121    =back
122    
123    =cut
124    
125    use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
126                                             experimental   => 1,
127                                             private        => 1 };
128    
129    sub AddSubsystemFilter {
130        # Get the parameters.
131        my ($filter, $args) = @_;
132        # We'll put the new filter stuff in here.
133        my @newFilters;
134        # Unless unusable subsystems are desired, we must add a clause to the filter.
135        # The default is that only usable subsystems are included.
136        my $usable = 1;
137        # This default can be overridden by the "-usable" parameter.
138        if (exists $args->{-usable}) {
139            $usable = $args->{-usable};
140        }
141        # If we're restricting to usable subsystems, add a filter to that effect.
142        if ($usable) {
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(ServerUtilities => 3);
165        }
166    }
167    
168    
169    
170  =head3 GetIdList  =head3 GetIdList
171    
172      my $ids = ServerThing::GetIdList($name => $args);      my $ids = ServerThing::GetIdList($name => $args, $optional);
173    
174  Get a named list of IDs from an argument structure. If the IDs are  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.  missing, or are not a list, an error will occur.
# Line 160  Line 184 
184    
185  Argument structure from which the ID list is to be extracted.  Argument structure from which the ID list is to be extracted.
186    
187    =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  =item RETURN  =item RETURN
193    
194  Returns a reference to a list of IDs taken from the argument structure.  Returns a reference to a list of IDs taken from the argument structure.
# Line 170  Line 199 
199    
200  sub GetIdList {  sub GetIdList {
201      # Get the parameters.      # Get the parameters.
202      my ($name, $args) = @_;      my ($name, $args, $optional) = @_;
203      # Try to get the IDs from the argument structure.      # Declare the return variable.
204      my $retVal = $args->{$name};      my $retVal;
205      # Throw an error if no member was found.      # Check the argument format.
206      Confess("No '$name' parameter found.") if ! defined $retVal;      if (! defined $args && $optional) {
207      # Get the parameter type. We was a list reference. If it's a scalar, we'll          # Here there are no parameters, but the arguments are optional so it's
208      # convert it to a singleton list. If it's anything else, it's an error.          # okay.
209            $retVal = [];
210        } elsif (ref $args ne 'HASH') {
211            # Here we have an invalid parameter structure.
212            Confess("No '$name' parameter present.");
213        } else {
214            # Here we have a hash with potential parameters in it. Try to get the
215            # IDs from the argument structure.
216            $retVal = $args->{$name};
217            # Was a member found?
218            if (! defined $retVal) {
219                # No. If we're optional, return an empty list; otherwise throw an error.
220                if ($optional) {
221                    $retVal = [];
222                } else {
223                    Confess("No '$name' parameter found.");
224                }
225            } else {
226                # Here we found something. Get the parameter type. We want a list reference.
227                # If it's a scalar, we'll convert it to a singleton list. If it's anything
228                # else, it's an error.
229      my $type = ref $retVal;      my $type = ref $retVal;
230      if (! $type) {      if (! $type) {
231          $retVal = [$retVal];          $retVal = [$retVal];
232      } elsif ($type ne 'ARRAY') {      } elsif ($type ne 'ARRAY') {
233          Confess("The '$name' parameter must be a list.");          Confess("The '$name' parameter must be a list.");
234      }      }
235            }
236        }
237        # Return the result.
238        return $retVal;
239    }
240    
241    
242    =head3 RunTool
243    
244        ServerThing::RunTool($name => $cmd);
245    
246    Run a command-line tool. A non-zero return value from the tool will cause
247    a fatal error, and the tool's error log will be traced.
248    
249    =over 4
250    
251    =item name
252    
253    Name to give to the tool in the error output.
254    
255    =item cmd
256    
257    Command to use for running the tool. This should be the complete command line.
258    The command should not contain any fancy piping, though it may redirect the
259    standard input and output. The command will be modified by this method to
260    redirect the error output to a temporary file.
261    
262    =back
263    
264    =cut
265    
266    sub RunTool {
267        # Get the parameters.
268        my ($name, $cmd) = @_;
269        # Compute the log file name.
270        my $errorLog = "$FIG_Config::temp/errors$$.log";
271        # Execute the command.
272        Trace("Executing command: $cmd") if T(ServerUtilities => 3);
273        my $res = system("$cmd 2> $errorLog");
274        Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
275        # Check the result code.
276        if ($res != 0) {
277            # We have an error. If tracing is on, trace it.
278            if (T(ServerUtilities => 1)) {
279                TraceErrorLog($name, $errorLog);
280            }
281            # Delete the error log.
282            unlink $errorLog;
283            # Confess the error.
284            Confess("$name command failed with error code $res.");
285        } else {
286            # Everything worked. Trace the error log if necessary.
287            if (T(ServerUtilities => 3) && -s $errorLog) {
288                TraceErrorLog($name, $errorLog);
289            }
290            # Delete the error log if there is one.
291            unlink $errorLog;
292        }
293    }
294    
295    
296    =head2 Gene Correspondence File Methods
297    
298    These methods relate to gene correspondence files, which are generated by the
299    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
300    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
301    copied into the organism directories themselves. At that point, the code below
302    will be modified to check the organism directories first and use the cache
303    directory if no file is found there.
304    
305    A gene correspondence file contains correspondences from a source genome to a
306    target genome. Most such correspondences are bidirectional best hits. A unidirectional
307    best hit may exist from the source genome to the target genome or in the reverse
308    direction from the targtet genome to the source genome. The cache directory itself
309    is divided into subdirectories by organism. The subdirectory has the source genome
310    name and the files themselves are named by the target genome.
311    
312    Some of the files are invalid and will be erased when they are found. A file is
313    considered invalid if it has a non-numeric value in a numeric column or if it
314    does not have any unidirectional hits from the target genome to the source
315    genome.
316    
317    The process of managing the correspondence files is tricky and dangerous because
318    of the possibility of race conditions. It can take several minutes to generate a
319    file, and if two processes try to generate the same file at the same time we need
320    to make sure they don't step on each other.
321    
322    In stored files, the source genome ID is always lexically lower than the target
323    genome ID. If a correspondence in the reverse direction is desired, the converse
324    file is found and the contents flipped automatically as they are read. So, the
325    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
326    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
327    B<100226.1> as the source and B<360108.3> as the target, the columns are
328    re-ordered and the arrows reversed before the file contents are passed to the
329    caller.
330    
331    =head4 Gene Correspondence List
332    
333    A gene correspondence file contains 18 columns. These are usually packaged as
334    a reference to list of lists. Each sub-list has the following format.
335    
336    =over 4
337    
338    =item 0
339    
340    The ID of a PEG in genome 1.
341    
342    =item 1
343    
344    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
345    
346    =item 2
347    
348    Count of the number of pairs of matching genes were found in the context.
349    
350    =item 3
351    
352    Pairs of corresponding genes from the contexts.
353    
354    =item 4
355    
356    The function of the gene in genome 1.
357    
358    =item 5
359    
360    The function of the gene in genome 2.
361    
362    =item 6
363    
364    Comma-separated list of aliases for the gene in genome 1 (any protein with an
365    identical sequence is considered an alias, whether or not it is actually the
366    name of the same gene in the same genome).
367    
368    =item 7
369    
370    Comma-separated list of aliases for the gene in genome 2 (any protein with an
371    identical sequence is considered an alias, whether or not it is actually the
372    name of the same gene in the same genome).
373    
374    =item 8
375    
376    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
377    
378    =item 9
379    
380    Percent identity over the region of the detected match.
381    
382    =item 10
383    
384    The P-score for the detected match.
385    
386    =item 11
387    
388    Beginning match coordinate in the protein encoded by the gene in genome 1.
389    
390    =item 12
391    
392    Ending match coordinate in the protein encoded by the gene in genome 1.
393    
394    =item 13
395    
396    Length of the protein encoded by the gene in genome 1.
397    
398    =item 14
399    
400    Beginning match coordinate in the protein encoded by the gene in genome 2.
401    
402    =item 15
403    
404    Ending match coordinate in the protein encoded by the gene in genome 2.
405    
406    =item 16
407    
408    Length of the protein encoded by the gene in genome 2.
409    
410    =item 17
411    
412    Bit score for the match. Divide by the length of the longer PEG to get
413    what we often refer to as a "normalized bit score".
414    
415    =back
416    
417    In the actual files, there will also be reverse correspondences indicated by a
418    back-arrow ("<-") in item (8). The output returned by the servers, however,
419    is filtered so that only forward correspondences occur. If a converse file
420    is used, the columns are re-ordered and the arrows reversed so that it looks
421    correct.
422    
423    =cut
424    
425    # hash for reversing the arrows
426    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
427    # list of columns that contain numeric values that need to be validated
428    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
429    
430    =head3 CheckForGeneCorrespondenceFile
431    
432        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
433    
434    Try to find a gene correspondence file for the specified genome pairing. If the
435    file exists, its name and an indication of whether or not it is in the correct
436    direction will be returned.
437    
438    =over 4
439    
440    =item genome1
441    
442    Source genome for the desired correspondence.
443    
444    =item genome2
445    
446    Target genome for the desired correspondence.
447    
448    =item RETURN
449    
450    Returns a two-element list. The first element is the name of the file containing the
451    correspondence, or C<undef> if the file does not exist. The second element is TRUE
452    if the correspondence would be forward or FALSE if the file needs to be flipped.
453    
454    =back
455    
456    =cut
457    
458    sub CheckForGeneCorrespondenceFile {
459        # Get the parameters.
460        my ($genome1, $genome2) = @_;
461        # Declare the return variables.
462        my ($fileName, $converse);
463        # Determine the ordering of the genome IDs.
464        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
465        $converse = ($genomeA ne $genome1);
466        # Look for a file containing the desired correspondence. (The code to check for a
467        # pre-computed file in the organism directories is currently turned off, because
468        # these files are all currently invalid.)
469        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
470        if (0 && -f $testFileName) {
471            # Use the pre-computed file.
472            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
473            $fileName = $testFileName;
474        } elsif (-f $corrFileName) {
475            $fileName = $corrFileName;
476            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
477        }
478      # Return the result.      # Return the result.
479        return ($fileName, $converse);
480    }
481    
482    
483    =head3 ComputeCorrespondenceFileName
484    
485        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
486    
487    Compute the name to be given to a genome correspondence file in the organism cache
488    and return the source and target genomes that would be in it.
489    
490    =over 4
491    
492    =item genome1
493    
494    Source genome for the desired correspondence.
495    
496    =item genome2
497    
498    Target genome for the desired correspondence.
499    
500    =item RETURN
501    
502    Returns a three-element list. The first element is the name of the file to contain the
503    correspondence, the second element is the name of the genome that would act as the
504    source genome in the file, and the third element is the name of the genome that would
505    act as the target genome in the file.
506    
507    =back
508    
509    =cut
510    
511    sub ComputeCorrespondenceFileName {
512        # Get the parameters.
513        my ($genome1, $genome2) = @_;
514        # Declare the return variables.
515        my ($fileName, $genomeA, $genomeB);
516        # Determine the ordering of the genome IDs.
517        if (MustFlipGenomeIDs($genome1, $genome2)) {
518            ($genomeA, $genomeB) = ($genome2, $genome1);
519        } else {
520            ($genomeA, $genomeB) = ($genome1, $genome2);
521        }
522        # Insure the source organism has a subdirectory in the organism cache.
523        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
524        # Compute the name of the correspondence file for the appropriate target genome.
525        $fileName = "$orgDir/$genomeB";
526        # Return the results.
527        return ($fileName, $genomeA, $genomeB);
528    }
529    
530    
531    =head3 ComputeCorresopndenceDirectory
532    
533        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
534    
535    Return the name of the directory that would contain the correspondence files
536    for the specified genome.
537    
538    =over 4
539    
540    =item genome
541    
542    ID of the genome whose correspondence file directory is desired.
543    
544    =item RETURN
545    
546    Returns the name of the directory of interest.
547    
548    =back
549    
550    =cut
551    
552    sub ComputeCorrespondenceDirectory {
553        # Get the parameters.
554        my ($genome) = @_;
555        # Insure the source organism has a subdirectory in the organism cache.
556        my $retVal = "$FIG_Config::orgCache/$genome";
557        Tracer::Insure($retVal, 0777);
558        # Return it.
559      return $retVal;      return $retVal;
560  }  }
561    
562    
563    =head3 CreateGeneCorrespondenceFile
564    
565        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
566    
567    Create a new gene correspondence file in the organism cache for the specified
568    genome correspondence. The name of the new file will be returned along with
569    an indicator of whether or not it is in the correct direction.
570    
571    =over 4
572    
573    =item genome1
574    
575    Source genome for the desired correspondence.
576    
577    =item genome2
578    
579    Target genome for the desired correspondence.
580    
581    =item RETURN
582    
583    Returns a two-element list. The first element is the name of the file containing the
584    correspondence, or C<undef> if an error occurred. The second element is TRUE
585    if the correspondence would be forward or FALSE if the file needs to be flipped.
586    
587    =back
588    
589    =cut
590    
591    sub CreateGeneCorrespondenceFile {
592        # Get the parameters.
593        my ($genome1, $genome2) = @_;
594        # Declare the return variables.
595        my ($fileName, $converse);
596        # Compute the ultimate name for the correspondence file.
597        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
598        $converse = ($genome1 ne $genomeA);
599        # Generate a temporary file name in the same directory. We'll build the temporary
600        # file and then rename it when we're done.
601        my $tempFileName = "$corrFileName.$$.tmp";
602        # This will be set to FALSE if we detect an error.
603        my $fileOK = 1;
604        # The file handles will be put in here.
605        my ($ih, $oh);
606        # Protect from errors.
607        eval {
608            # Open the temporary file for output.
609            $oh = Open(undef, ">$tempFileName");
610            # Open a pipe to get the correspondence data.
611            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
612            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
613            # Copy the pipe date into the temporary file.
614            while (! eof $ih) {
615                my $line = <$ih>;
616                print $oh $line;
617            }
618            # Close both files. If the close fails we need to know: it means there was a pipe
619            # error.
620            $fileOK &&= close $ih;
621            $fileOK &&= close $oh;
622        };
623        if ($@) {
624            # Here a fatal error of some sort occurred. We need to force the files closed.
625            close $ih if $ih;
626            close $oh if $oh;
627        } elsif ($fileOK) {
628            # Here everything worked. Try to rename the temporary file to the real
629            # file name.
630            if (rename $tempFileName, $corrFileName) {
631                # Everything is ok, fix the permissions and return the file name.
632                chmod 0664, $corrFileName;
633                $fileName = $corrFileName;
634                Trace("Created correspondence file $fileName.") if T(Corr => 3);
635            }
636        }
637        # If the temporary file exists, delete it.
638        if (-f $tempFileName) {
639            unlink $tempFileName;
640        }
641        # Return the results.
642        return ($fileName, $converse);
643    }
644    
645    
646    =head3 MustFlipGenomeIDs
647    
648        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
649    
650    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
651    order, they are stored in the converse order in correspondence files on the server.
652    This is a simple method that allows the caller to check for the need to flip.
653    
654    =over 4
655    
656    =item genome1
657    
658    ID of the proposed source genome.
659    
660    =item genome2
661    
662    ID of the proposed target genome.
663    
664    =item RETURN
665    
666    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
667    it would be stored as a source.
668    
669    =cut
670    
671    sub MustFlipGenomeIDs {
672        # Get the parameters.
673        my ($genome1, $genome2) = @_;
674        # Return an indication.
675        return ($genome1 gt $genome2);
676    }
677    
678    
679    =head3 ReadGeneCorrespondenceFile
680    
681        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
682    
683    Return the contents of the specified gene correspondence file in the form of
684    a list of lists, with backward correspondences filtered out. If the file is
685    for the converse of the desired correspondence, the columns will be reordered
686    automatically so that it looks as if the file were designed for the proper
687    direction.
688    
689    =over 4
690    
691    =item fileName
692    
693    The name of the gene correspondence file to read.
694    
695    =item converse (optional)
696    
697    TRUE if the file is for the converse of the desired correspondence, else FALSE.
698    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
699    meaning we want to use the file as it appears on disk.
700    
701    =item all (optional)
702    
703    TRUE if backward unidirectional correspondences should be included in the output.
704    The default is FALSE, in which case only forward and bidirectional correspondences
705    are included.
706    
707    =item RETURN
708    
709    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
710    If the file's contents are invalid or an error occurs, an undefined value will be
711    returned.
712    
713    =back
714    
715    =cut
716    
717    sub ReadGeneCorrespondenceFile {
718        # Get the parameters.
719        my ($fileName, $converse, $all) = @_;
720        # Declare the return variable. We will only put something in here if we are
721        # completely successful.
722        my $retVal;
723        # This value will be set to 1 if an error is detected.
724        my $error = 0;
725        # Try to open the file.
726        my $ih;
727        Trace("Reading correspondence file $fileName.") if T(3);
728        if (! open $ih, "<$fileName") {
729            # Here the open failed, so we have an error.
730            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
731            $error = 1;
732        }
733        # The gene correspondence list will be built in here.
734        my @corrList;
735        # This variable will be set to TRUE if we find a reverse correspondence somewhere
736        # in the file. Not finding one is an error.
737        my $reverseFound = 0;
738        # Loop until we hit the end of the file or an error occurs. We must check the error
739        # first in case the file handle failed to open.
740        while (! $error && ! eof $ih) {
741            # Get the current line.
742            my @row = Tracer::GetLine($ih);
743            # Get the correspondence direction and check for a reverse arrow.
744            $reverseFound = 1 if ($row[8] eq '<-');
745            # If we're in converse mode, reformat the line.
746            if ($converse) {
747                ReverseGeneCorrespondenceRow(\@row);
748            }
749            # Validate the row.
750            if (ValidateGeneCorrespondenceRow(\@row)) {
751                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
752                $error = 1;
753            }
754            # If this row is in the correct direction, keep it.
755            if ($all || $row[8] ne '<-') {
756                push @corrList, \@row;
757            }
758        }
759        # Close the input file.
760        close $ih;
761        # If we have no errors and we found a reverse arrow, keep the result.
762        if (! $error) {
763            if ($reverseFound) {
764                $retVal = \@corrList;
765            } else {
766                Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
767            }
768        }
769        # Return the result (if any).
770        return $retVal;
771    }
772    
773    =head3 ReverseGeneCorrespondenceRow
774    
775        ServerThing::ReverseGeneCorrespondenceRow($row)
776    
777    Convert a gene correspondence row to represent the converse correspondence. The
778    elements in the row will be reordered to represent a correspondence from the
779    target genome to the source genome.
780    
781    =over 4
782    
783    =item row
784    
785    Reference to a list containing a single row from a L</Gene Correspondence List>.
786    
787    =back
788    
789    =cut
790    
791    sub ReverseGeneCorrespondenceRow {
792        # Get the parameters.
793        my ($row) = @_;
794        # Flip the row in place.
795        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
796         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
797         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
798        # Flip the arrow.
799        $row->[8] = ARROW_FLIP->{$row->[8]};
800        # Flip the pairs.
801        my @elements = split /,/, $row->[3];
802        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
803    }
804    
805    =head3 ValidateGeneCorrespondenceRow
806    
807        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
808    
809    Validate a gene correspondence row. The numeric fields are checked to insure they
810    are numeric and the source and target gene IDs are validated. The return value will
811    indicate the number of errors found.
812    
813    =over 4
814    
815    =item row
816    
817    Reference to a list containing a single row from a L</Gene Correspondence List>.
818    
819    =item RETURN
820    
821    Returns the number of errors found in the row. A return of C<0> indicates the row
822    is valid.
823    
824    =back
825    
826    =cut
827    
828    sub ValidateGeneCorrespondenceRow {
829        # Get the parameters.
830        my ($row, $genome1, $genome2) = @_;
831        # Denote no errors have been found so far.
832        my $retVal = 0;
833        # Check for non-numeric values in the number columns.
834        for my $col (@{NUM_COLS()}) {
835            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
836                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
837                $retVal++;
838            }
839        }
840        # Check the gene IDs.
841        for my $col (0, 1) {
842            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
843                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
844                $retVal++;
845            }
846        }
847        # Verify the arrow.
848        unless (exists ARROW_FLIP->{$row->[8]}) {
849            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
850            $retVal++;
851        }
852        # Return the error count.
853        return $retVal;
854    }
855    
856    
857    =head2 Internal Utility Methods
858    
859    The methods in this section are used internally by this package.
860    
861    =head3 RunRequest
862    
863        ServerThing::RunRequest($cgi, $serverName);
864    
865    Run a request from the specified server using the incoming CGI parameter
866    object for the parameters.
867    
868    =over 4
869    
870    =item cgi
871    
872    CGI query object containing the parameters from the web service request. The
873    significant parameters are as follows.
874    
875    =over 8
876    
877    =item function
878    
879    Name of the function to run.
880    
881    =item args
882    
883    Parameters for the function.
884    
885    =item encoding
886    
887    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
888    by the Java interface).
889    
890    =back
891    
892    Certain unusual requests can come in outside of the standard function interface.
893    These are indicated by special parameters that override all the others.
894    
895    =over 8
896    
897    =item pod
898    
899    Display a POD documentation module.
900    
901    =item code
902    
903    Display an example code file.
904    
905    =item file
906    
907    Transfer a file (not implemented).
908    
909    =back
910    
911    =item serverThing
912    
913    Server object against which to run the request.
914    
915    =back
916    
917    =cut
918    
919    sub RunRequest {
920        # Get the parameters.
921        my ($cgi, $serverThing, $docURL) = @_;
922        # Determine the request type.
923        if ($cgi->param('pod')) {
924            # Here we have a documentation request. In this case, we produce POD HTML.
925            ProducePod($cgi->param('pod'));
926        } elsif ($cgi->param('code')) {
927            # Here the user wants to see the code for one of our scripts.
928            LineNumberize($cgi->param('code'));
929        } elsif ($cgi->param('file')) {
930            # Here we have a file request. Process according to the type.
931            my $type = $cgi->param('file');
932            if ($type eq 'open') {
933                OpenFile($cgi->param('name'));
934            } elsif ($type eq 'create') {
935                CreateFile();
936            } elsif ($type eq 'read') {
937                ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
938            } elsif ($type eq 'write') {
939                WriteChunk($cgi->param('name'), $cgi->param('data'));
940            } else {
941                Die("Invalid file function \"$type\".");
942            }
943        } else {
944            # The default is a function request. Get the function name.
945            my $function = $cgi->param('function') || "";
946            Trace("Server function for task $$ is $function.") if T(3);
947            # Insure the function name is valid.
948            Die("Invalid function name.")
949                if $function =~ /\W/;
950            # Determing the encoding scheme. The default is YAML.
951            my $encoding = $cgi->param('encoding') || 'yaml';
952            # The parameter structure will go in here.
953            my $args;
954            # Start the timer.
955            my $start = time();
956            # The output document goes in here.
957            my $document;
958            # The sapling database goes in here.
959            my $sapling;
960            # Protect from errors.
961            eval {
962                # Here we parse the arguments. This is affected by the encoding parameter.
963                # Get the argument string.
964                my $argString = $cgi->param('args');
965                if ($encoding eq 'yaml') {
966                    # Parse the arguments using YAML.
967                    $args = YAML::Load($argString);
968                } elsif ($encoding eq 'json') {
969                    # Parse the arguments using JSON.
970                    Trace("Incoming string is:\n$argString") if T(3);
971                    $args = JSON::Any->jsonToObj($argString);
972                } else {
973                    Die("Invalid encoding type $encoding.");
974                }
975            };
976            # Check to make sure we got everything.
977            if ($@) {
978                SendError($@, "Error formatting parameters.");
979            } elsif (! $function) {
980                SendError("No function specified.", "No function specified.");
981            } else {
982                $document = eval { $serverThing->$function($args) };
983                # If we have an error, create an error document.
984                if ($@) {
985                    SendError($@, "Error detected by service.");
986                    Trace("Error encountered by service: $@") if T(0);
987                } else {
988                    # No error, so we output the result. Start with an HTML header.
989                    print $cgi->header(-type => 'text/plain');
990                    # The nature of the output depends on the encoding type.
991                    my $string;
992                    if ($encoding eq 'yaml') {
993                        $string = YAML::Dump($document);
994                    } else {
995                        $string = JSON::Any->objToJson($document);
996                    }
997                    print $string;
998                    MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
999                }
1000            }
1001            # Stop the timer.
1002            my $duration = int(time() - $start + 0.5);
1003            Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1004        }
1005    }
1006    
1007    =head3 CreateFile
1008    
1009        ServerThing::CreateFile();
1010    
1011    Create a new, empty temporary file and send its name back to the client.
1012    
1013    =cut
1014    
1015    sub CreateFile {
1016        ##TODO: Code
1017    }
1018    
1019    =head3 OpenFile
1020    
1021        ServerThing::OpenFile($name);
1022    
1023    Send the length of the named file back to the client.
1024    
1025    =over 4
1026    
1027    =item name
1028    
1029    ##TODO: name description
1030    
1031    =back
1032    
1033    =cut
1034    
1035    sub OpenFile {
1036        # Get the parameters.
1037        my ($name) = @_;
1038        ##TODO: Code
1039    }
1040    
1041    =head3 ReadChunk
1042    
1043        ServerThing::ReadChunk($name, $location, $size);
1044    
1045    Read the indicated number of bytes from the specified location of the
1046    named file and send them back to the client.
1047    
1048    =over 4
1049    
1050    =item name
1051    
1052    ##TODO: name description
1053    
1054    =item location
1055    
1056    ##TODO: location description
1057    
1058    =item size
1059    
1060    ##TODO: size description
1061    
1062    =back
1063    
1064    =cut
1065    
1066    sub ReadChunk {
1067        # Get the parameters.
1068        my ($name, $location, $size) = @_;
1069        ##TODO: Code
1070    }
1071    
1072    =head3 WriteChunk
1073    
1074        ServerThing::WriteChunk($name, $data);
1075    
1076    Write the specified data to the named file.
1077    
1078    =over 4
1079    
1080    =item name
1081    
1082    ##TODO: name description
1083    
1084    =item data
1085    
1086    ##TODO: data description
1087    
1088    =back
1089    
1090    =cut
1091    
1092    sub WriteChunk {
1093        # Get the parameters.
1094        my ($name, $data) = @_;
1095        ##TODO: Code
1096    }
1097    
1098    
1099    =head3 LineNumberize
1100    
1101        ServerThing::LineNumberize($module);
1102    
1103    Output the module line by line with line numbers
1104    
1105    =over 4
1106    
1107    =item module
1108    
1109    Name of the module to line numberized
1110    
1111    =back
1112    
1113    =cut
1114    
1115    sub LineNumberize {
1116        # Get the parameters.
1117        my ($module) = @_;
1118        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1119        # Start the output page.
1120        print CGI::header();
1121        print CGI::start_html(-title => 'Documentation Page',
1122                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1123        # Protect from errors.
1124        eval {
1125            if (-e $fks_path) {
1126                print "<pre>\n";
1127                my $i = 1;
1128                foreach my $line (`cat $fks_path`) {
1129                    print "$i.\t$line";
1130                    $i++;
1131                }
1132                print "</pre>\n";
1133            } else {
1134                print "File $fks_path not found";
1135            }
1136        };
1137        # Process any error.
1138        if ($@) {
1139            print CGI::blockquote({ class => 'error' }, $@);
1140        }
1141        # Close off the page.
1142        print CGI::end_html();
1143    
1144    }
1145    
1146    =head3 ProducePod
1147    
1148        ServerThing::ProducePod($module);
1149    
1150    Output the POD documentation for the specified module.
1151    
1152    =over 4
1153    
1154    =item module
1155    
1156    Name of the module whose POD document is to be displayed.
1157    
1158    =back
1159    
1160    =cut
1161    
1162    sub ProducePod {
1163        # Get the parameters.
1164        my ($module) = @_;
1165        # Start the output page.
1166        print CGI::header();
1167        print CGI::start_html(-title => "$module Documentation Page",
1168                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1169        # Protect from errors.
1170        eval {
1171            # We'll format the HTML text in here.
1172            require DocUtils;
1173            my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
1174            # Output the POD HTML.
1175            print $html;
1176        };
1177        # Process any error.
1178        if ($@) {
1179            print CGI::blockquote({ class => 'error' }, $@);
1180        }
1181        # Close off the page.
1182        print CGI::end_html();
1183    
1184    }
1185    
1186    =head3 TraceErrorLog
1187    
1188        ServerThing::TraceErrorLog($name, $errorLog);
1189    
1190    Trace the specified error log file. This is a very dinky routine that
1191    performs a task required by L</RunTool> in multiple places.
1192    
1193    =over 4
1194    
1195    =item name
1196    
1197    Name of the tool relevant to the log file.
1198    
1199    =item errorLog
1200    
1201    Name of the log file.
1202    
1203    =back
1204    
1205    =cut
1206    
1207    sub TraceErrorLog {
1208        my ($name, $errorLog) = @_;
1209        my $errorData = Tracer::GetFile($errorLog);
1210        Trace("$name error log:\n$errorData");
1211    }
1212    
1213    =head3 SendError
1214    
1215        ServerThing::SendError($message, $status);
1216    
1217    Fail an HTTP request with the specified error message and the specified
1218    status message.
1219    
1220    =over 4
1221    
1222    =item message
1223    
1224    Detailed error message. This is sent as the page content.
1225    
1226    =item status
1227    
1228    Status message. This is sent as part of the status code.
1229    
1230    =back
1231    
1232    =cut
1233    
1234    sub SendError {
1235        # Get the parameters.
1236        my ($message, $status) = @_;
1237        Trace("Error \"$status\" $message") if T(2);
1238        # Check for a DBserver error. These can be retried and get a special status
1239        # code.
1240        my $realStatus;
1241        if ($message =~ /DBServer Error:\s+/) {
1242            $realStatus = "503 $status";
1243        } else {
1244            $realStatus = "500 $status";
1245        }
1246        # Print the header and the status message.
1247        print CGI::header(-type => 'text/plain',
1248                          -status => $realStatus);
1249        # Print the detailed message.
1250        print $message;
1251    }
1252    
1253    
1254  1;  1;

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.51

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3