[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.19, Thu Dec 3 15:34:16 2009 UTC revision 1.72, Thu Mar 17 21:32:30 2011 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;
11      use Time::HiRes;      use Time::HiRes;
# Line 14  Line 15 
15      no warnings qw(once);      no warnings qw(once);
16    
17      # Maximum number of requests to run per invocation.      # Maximum number of requests to run per invocation.
18      use constant MAX_REQUESTS => 500;      use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
# Line 30  Line 31 
31  sub RunServer {  sub RunServer {
32      # Get the parameters.      # Get the parameters.
33      my ($serverName, $key) = @_;      my ($serverName, $key) = @_;
34        # Set up tracing. We never do CGI tracing here; the only question is whether
35        # or not the caller passed in a tracing key. If he didn't, we use the server
36        # name.
37        ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
38      # Turn off YAML compression, which causes problems with some of our hash keys.      # Turn off YAML compression, which causes problems with some of our hash keys.
39      $YAML::CompressSeries = 0;      $YAML::CompressSeries = 0;
40      # Create the server object.      # Create the server object.
41      Trace("Requiring $serverName for task $$.") if T(3);      Trace("Requiring $serverName for task $$.") if T(3);
42      eval {      eval {
43          require "$serverName.pm";          my $output = $serverName;
44            $output =~ s/::/\//;
45            require "$output.pm";
46      };      };
47      # If we have an error, create an error document.      # If we have an error, create an error document.
48      if ($@) {      if ($@) {
# Line 48  Line 55 
55          if ($@) {          if ($@) {
56              SendError($@, "Could not start server.");              SendError($@, "Could not start server.");
57          } else {          } else {
58              # No error, so now we can process the request.              # No error, so now we can process the request. First, get the method list.
59                my $methods = $serverThing->methods();
60                # Store it in the object so we can use it to validate methods.
61                my %methodHash = map { $_ => 1 } @$methods;
62                $serverThing->{methods} = \%methodHash;
63              my $cgi;              my $cgi;
64              if (! defined $key) {              if (! defined $key) {
65                  # No tracing key, so presume we're a web service. Check for Fast CGI.                  # No tracing key, so presume we're a web service. Check for Fast CGI.
66                  if ($ENV{REQUEST_METHOD} eq '') {                  if ($ENV{REQUEST_METHOD} eq '') {
                     # Here we're doing Fast CGI. In this case, the tracing key is the  
                     # server name.  
                     ETracing($serverName);  
67                      # Count the number of requests.                      # Count the number of requests.
68                      my $requests = 0;                      my $requests = 0;
69                        # warn "Starting fast CGI loop.\n"; ##HACK Trace("Starting Fast CGI loop.") if T(3);
70                      # Loop through the fast CGI requests. If we have request throttling,                      # Loop through the fast CGI requests. If we have request throttling,
71                      # we exit after a maximum number of requests has been exceeded.                      # we exit after a maximum number of requests has been exceeded.
72                      require CGI::Fast;                      require CGI::Fast;
73                      while (($cgi = new CGI::Fast()) &&                      open(SERVER_STDERR, ">&", *STDERR);
74                             (MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS)) {                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
75                               ($cgi = new CGI::Fast())) {
76                            #
77                            # Remap STDERR. Inside here, our STDERR is a tie to a FCGI::Stream
78                            # so we need to save it to keep FCGI happy.
79                            #
80                            *SAVED_STDERR = *STDERR;
81                            *STDERR = *SERVER_STDERR;
82                            my $function = $cgi->param('function') || "<non-functional>"; # (useful if we do tracing in here)
83                            # warn "Function request is $function in task $$.\n"; ##HACK
84                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
85                          Trace("Request $requests complete in task $$.") if T(3);                          # warn "$requests requests complete in fast CGI task $$.\n"; ##HACK Trace("Request $requests complete in task $$.") if T(3);
86                            *STDERR = *SAVED_STDERR;
87                      }                      }
88                      Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);                      # warn "Terminating FastCGI task $$ after $requests requests.\n"; ##HACK Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
89                        close(SERVER_STDERR);
90                  } else {                  } else {
91                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
92                      my $cgi = CGI->new();                      my $cgi = CGI->new();
93                      # Check for a source parameter. This gets used as the tracing key.                      # Check for a source parameter. This gets used as the tracing key.
94                      $key = $cgi->param('source');                      $key = $cgi->param('source');
                     if (! $key) {  
                         # No source parameter, so do normal setup. Note we turn off  
                         # CGI parameter tracing.  
                         ETracing($cgi, 'noParms');  
                     } else {  
                         # Set up tracing using the specified key.  
                         ETracing($key);  
                     }  
95                      # Run this request.                      # Run this request.
96                      RunRequest($cgi, $serverThing);                      RunRequest($cgi, $serverThing);
97                  }                  }
# Line 88  Line 100 
100                  # key to find the parm file and create the CGI object from that.                  # key to find the parm file and create the CGI object from that.
101                  my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");                  my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
102                  $cgi = CGI->new($ih);                  $cgi = CGI->new($ih);
                 # Set up tracing using the specified key.  
                 ETracing($key);  
103                  # Run this request.                  # Run this request.
104                  RunRequest($cgi, $serverThing);                  RunRequest($cgi, $serverThing);
105              }              }
# Line 103  Line 113 
113  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
114  server modules.  server modules.
115    
116    =head3 AddSubsystemFilter
117    
118        ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
119    
120    Add subsystem filtering information to the specified query filter clause
121    based on data in the argument hash. The argument hash will be checked for
122    the C<-usable> parameter, which includes or excludes unusuable subsystems,
123    the C<-exclude> parameter, which lists types of subsystems that should be
124    excluded, and the C<-aux> parameter, which filters on auxiliary roles.
125    
126    =over 4
127    
128    =item filter
129    
130    Reference to the current filter string. If additional filtering is required,
131    this string will be updated.
132    
133    =item args
134    
135    Reference to the parameter hash for the current server call. This hash will
136    be examined for the C<-usable> and C<-exclude> parameters.
137    
138    =item roles
139    
140    If TRUE, role filtering will be applied. In this case, the default action
141    is to exclude auxiliary roles unless C<-aux> is TRUE.
142    
143    =back
144    
145    =cut
146    
147    use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
148                                             experimental   => 1,
149                                             private        => 1 };
150    
151    sub AddSubsystemFilter {
152        # Get the parameters.
153        my ($filter, $args, $roles) = @_;
154        # We'll put the new filter stuff in here.
155        my @newFilters;
156        # Unless unusable subsystems are desired, we must add a clause to the filter.
157        # The default is that only usable subsystems are included.
158        my $usable = 1;
159        # This default can be overridden by the "-usable" parameter.
160        if (exists $args->{-usable}) {
161            $usable = $args->{-usable};
162        }
163        # If we're restricting to usable subsystems, add a filter to that effect.
164        if ($usable) {
165            push @newFilters, "Subsystem(usable) = 1";
166        }
167        # Check for exclusion filters.
168        my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
169        for my $exclusion (@$exclusions) {
170            if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
171                Confess("Invalid exclusion type \"$exclusion\".");
172            } else {
173                # Here we have to exclude subsystems of the specified type.
174                push @newFilters, "Subsystem($exclusion) = 0";
175            }
176        }
177        # Check for role filtering.
178        if ($roles) {
179            # Here, we filter out auxiliary roles unless the user requests
180            # them.
181            if (! $args->{-aux}) {
182                push @newFilters, "Includes(auxiliary) = 0"
183            }
184        }
185        # Do we need to update the incoming filter?
186        if (@newFilters) {
187            # Yes. If the incoming filter is nonempty, push it onto the list
188            # so it gets included in the result.
189            if ($$filter) {
190                push @newFilters, $$filter;
191            }
192            # Put all the filters together to form the new filter.
193            $$filter = join(" AND ", @newFilters);
194            Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
195        }
196    }
197    
198    
199    
200  =head3 GetIdList  =head3 GetIdList
201    
202      my $ids = ServerThing::GetIdList($name => $args, $optional);      my $ids = ServerThing::GetIdList($name => $args, $optional);
# Line 136  Line 230 
230  sub GetIdList {  sub GetIdList {
231      # Get the parameters.      # Get the parameters.
232      my ($name, $args, $optional) = @_;      my ($name, $args, $optional) = @_;
233      # Try to get the IDs from the argument structure.      # Declare the return variable.
234      my $retVal = $args->{$name};      my $retVal;
235        # Check the argument format.
236        if (! defined $args && $optional) {
237            # Here there are no parameters, but the arguments are optional so it's
238            # okay.
239            $retVal = [];
240        } elsif (ref $args ne 'HASH') {
241            # Here we have an invalid parameter structure.
242            Confess("No '$name' parameter present.");
243        } else {
244            # Here we have a hash with potential parameters in it. Try to get the
245            # IDs from the argument structure.
246            $retVal = $args->{$name};
247      # Was a member found?      # Was a member found?
248      if (! defined $retVal) {      if (! defined $retVal) {
249          # No. If we're optional, return an empty list; otherwise throw an error.          # No. If we're optional, return an empty list; otherwise throw an error.
# Line 147  Line 253 
253              Confess("No '$name' parameter found.");              Confess("No '$name' parameter found.");
254          }          }
255      } else {      } else {
256          # Here we found something. Get the parameter type. We was a list reference.              # Here we found something. Get the parameter type. We want a list reference.
257          # If it's a scalar, we'll convert it to a singleton list. If it's anything          # If it's a scalar, we'll convert it to a singleton list. If it's anything
258          # else, it's an error.          # else, it's an error.
259          my $type = ref $retVal;          my $type = ref $retVal;
# Line 157  Line 263 
263              Confess("The '$name' parameter must be a list.");              Confess("The '$name' parameter must be a list.");
264          }          }
265      }      }
266        }
267      # Return the result.      # Return the result.
268      return $retVal;      return $retVal;
269  }  }
# Line 192  Line 299 
299      # Compute the log file name.      # Compute the log file name.
300      my $errorLog = "$FIG_Config::temp/errors$$.log";      my $errorLog = "$FIG_Config::temp/errors$$.log";
301      # Execute the command.      # Execute the command.
302      Trace("Executing command: $cmd") if T(3);      Trace("Executing command: $cmd") if T(ServerUtilities => 3);
303      my $res = system("$cmd 2> $errorLog");      my $res = system("$cmd 2> $errorLog");
304      Trace("Return from $name tool is $res.") if T(3);      Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
305      # Check the result code.      # Check the result code.
306      if ($res != 0) {      if ($res != 0) {
307          # We have an error. If tracing is on, trace it.          # We have an error. If tracing is on, trace it.
308          if (T(1)) {          if (T(ServerUtilities => 1)) {
309              TraceErrorLog($name, $errorLog);              TraceErrorLog($name, $errorLog);
310          }          }
311          # Delete the error log.          # Delete the error log.
# Line 207  Line 314 
314          Confess("$name command failed with error code $res.");          Confess("$name command failed with error code $res.");
315      } else {      } else {
316          # Everything worked. Trace the error log if necessary.          # Everything worked. Trace the error log if necessary.
317          if (T(3) && -s $errorLog) {          if (T(ServerUtilities => 3) && -s $errorLog) {
318              TraceErrorLog($name, $errorLog);              TraceErrorLog($name, $errorLog);
319          }          }
320          # Delete the error log if there is one.          # Delete the error log if there is one.
# Line 215  Line 322 
322      }      }
323  }  }
324    
325    =head3 ReadCountVector
326    
327        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
328    
329    Extract a count vector from a query. The query can contain zero or more results,
330    and the vectors in the specified result field of the query must be concatenated
331    together in order. This method is optimized for the case (expected to be most
332    common) where there is only one result.
333    
334    =over 4
335    
336    =item qh
337    
338    Handle for the query from which results are to be extracted.
339    
340    =item field
341    
342    Name of the field containing the count vectors.
343    
344    =item rawFlag
345    
346    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
347    as reference to a list of numbers.
348    
349    =item RETURN
350    
351    Returns the desired vector, either encoded as a string or as a reference to a list
352    of numbers.
353    
354    =back
355    
356    =cut
357    
358    sub ReadCountVector {
359        # Get the parameters.
360        my ($qh, $field, $rawFlag) = @_;
361        # Declare the return variable.
362        my $retVal;
363        # Loop through the query results.
364        while (my $resultRow = $qh->Fetch()) {
365            # Get this vector.
366            my ($levelVector) = $resultRow->Value($field, $rawFlag);
367            # Is this the first result?
368            if (! defined $retVal) {
369                # Yes. Assign the result directly.
370                $retVal = $levelVector;
371            } elsif ($rawFlag) {
372                # This is a second result and the vectors are coded as strings.
373                $retVal .= $levelVector;
374            } else {
375                # This is a second result and the vectors are coded as array references.
376                push @$retVal, @$levelVector;
377            }
378        }
379        # Return the result.
380        return $retVal;
381    }
382    
383    =head3 ChangeDB
384    
385        ServerThing::ChangeDB($thing, $newDbName);
386    
387    Change the sapling database used by this server. The old database will be closed and a
388    new one attached.
389    
390    =over 4
391    
392    =item newDbName
393    
394    Name of the new Sapling database on which this server should operate. If omitted, the
395    default database will be used.
396    
397    =back
398    
399    =cut
400    
401    sub ChangeDB {
402        # Get the parameters.
403        my ($thing, $newDbName) = @_;
404        # Default the db-name if it's not specified.
405        if (! defined $newDbName) {
406            $newDbName = $FIG_Config::saplingDB;
407        }
408        # Check to see if we really need to change.
409        my $oldDB = $thing->{db};
410        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
411            # We need a new sapling.
412            require Sapling;
413            my $newDB = Sapling->new(dbName => $newDbName);
414            $thing->{db} = $newDB;
415        }
416    }
417    
418    
419    =head2 Gene Correspondence File Methods
420    
421    These methods relate to gene correspondence files, which are generated by the
422    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
423    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
424    copied into the organism directories themselves. At that point, the code below
425    will be modified to check the organism directories first and use the cache
426    directory if no file is found there.
427    
428    A gene correspondence file contains correspondences from a source genome to a
429    target genome. Most such correspondences are bidirectional best hits. A unidirectional
430    best hit may exist from the source genome to the target genome or in the reverse
431    direction from the targtet genome to the source genome. The cache directory itself
432    is divided into subdirectories by organism. The subdirectory has the source genome
433    name and the files themselves are named by the target genome.
434    
435    Some of the files are invalid and will be erased when they are found. A file is
436    considered invalid if it has a non-numeric value in a numeric column or if it
437    does not have any unidirectional hits from the target genome to the source
438    genome.
439    
440    The process of managing the correspondence files is tricky and dangerous because
441    of the possibility of race conditions. It can take several minutes to generate a
442    file, and if two processes try to generate the same file at the same time we need
443    to make sure they don't step on each other.
444    
445    In stored files, the source genome ID is always lexically lower than the target
446    genome ID. If a correspondence in the reverse direction is desired, the converse
447    file is found and the contents flipped automatically as they are read. So, the
448    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
449    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
450    B<100226.1> as the source and B<360108.3> as the target, the columns are
451    re-ordered and the arrows reversed before the file contents are passed to the
452    caller.
453    
454    =head4 Gene Correspondence List
455    
456    A gene correspondence file contains 18 columns. These are usually packaged as
457    a reference to list of lists. Each sub-list has the following format.
458    
459    =over 4
460    
461    =item 0
462    
463    The ID of a PEG in genome 1.
464    
465    =item 1
466    
467    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
468    
469    =item 2
470    
471    Count of the number of pairs of matching genes were found in the context.
472    
473    =item 3
474    
475    Pairs of corresponding genes from the contexts.
476    
477    =item 4
478    
479    The function of the gene in genome 1.
480    
481    =item 5
482    
483    The function of the gene in genome 2.
484    
485    =item 6
486    
487    Comma-separated list of aliases for the gene in genome 1 (any protein with an
488    identical sequence is considered an alias, whether or not it is actually the
489    name of the same gene in the same genome).
490    
491    =item 7
492    
493    Comma-separated list of aliases for the gene in genome 2 (any protein with an
494    identical sequence is considered an alias, whether or not it is actually the
495    name of the same gene in the same genome).
496    
497    =item 8
498    
499    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
500    
501    =item 9
502    
503    Percent identity over the region of the detected match.
504    
505    =item 10
506    
507    The P-score for the detected match.
508    
509    =item 11
510    
511    Beginning match coordinate in the protein encoded by the gene in genome 1.
512    
513    =item 12
514    
515    Ending match coordinate in the protein encoded by the gene in genome 1.
516    
517    =item 13
518    
519    Length of the protein encoded by the gene in genome 1.
520    
521    =item 14
522    
523    Beginning match coordinate in the protein encoded by the gene in genome 2.
524    
525    =item 15
526    
527    Ending match coordinate in the protein encoded by the gene in genome 2.
528    
529    =item 16
530    
531    Length of the protein encoded by the gene in genome 2.
532    
533    =item 17
534    
535    Bit score for the match. Divide by the length of the longer PEG to get
536    what we often refer to as a "normalized bit score".
537    
538    =item 18 (optional)
539    
540    Clear-correspondence indicator. If present, will be C<1> if the correspondence is a
541    clear bidirectional best hit (no similar candidates) and C<0> otherwise.
542    
543    =back
544    
545    In the actual files, there will also be reverse correspondences indicated by a
546    back-arrow ("<-") in item (8). The output returned by the servers, however,
547    is filtered so that only forward correspondences occur. If a converse file
548    is used, the columns are re-ordered and the arrows reversed so that it looks
549    correct.
550    
551    =cut
552    
553    # hash for reversing the arrows
554    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
555    # list of columns that contain numeric values that need to be validated
556    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
557    
558    =head3 CheckForGeneCorrespondenceFile
559    
560        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
561    
562    Try to find a gene correspondence file for the specified genome pairing. If the
563    file exists, its name and an indication of whether or not it is in the correct
564    direction will be returned.
565    
566    =over 4
567    
568    =item genome1
569    
570    Source genome for the desired correspondence.
571    
572    =item genome2
573    
574    Target genome for the desired correspondence.
575    
576    =item RETURN
577    
578    Returns a two-element list. The first element is the name of the file containing the
579    correspondence, or C<undef> if the file does not exist. The second element is TRUE
580    if the correspondence would be forward or FALSE if the file needs to be flipped.
581    
582    =back
583    
584    =cut
585    
586    sub CheckForGeneCorrespondenceFile {
587        # Get the parameters.
588        my ($genome1, $genome2) = @_;
589        # Declare the return variables.
590        my ($fileName, $converse);
591        # Determine the ordering of the genome IDs.
592        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
593        $converse = ($genomeA ne $genome1);
594        # Look for a file containing the desired correspondence. (The code to check for a
595        # pre-computed file in the organism directories is currently turned off, because
596        # these files are all currently invalid.)
597        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
598        if (0 && -f $testFileName) {
599            # Use the pre-computed file.
600            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
601            $fileName = $testFileName;
602        } elsif (-f $corrFileName) {
603            $fileName = $corrFileName;
604            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
605        }
606        # Return the result.
607        return ($fileName, $converse);
608    }
609    
610    
611    =head3 ComputeCorrespondenceFileName
612    
613        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
614    
615    Compute the name to be given to a genome correspondence file in the organism cache
616    and return the source and target genomes that would be in it.
617    
618    =over 4
619    
620    =item genome1
621    
622    Source genome for the desired correspondence.
623    
624    =item genome2
625    
626    Target genome for the desired correspondence.
627    
628    =item RETURN
629    
630    Returns a three-element list. The first element is the name of the file to contain the
631    correspondence, the second element is the name of the genome that would act as the
632    source genome in the file, and the third element is the name of the genome that would
633    act as the target genome in the file.
634    
635    =back
636    
637    =cut
638    
639    sub ComputeCorrespondenceFileName {
640        # Get the parameters.
641        my ($genome1, $genome2) = @_;
642        # Declare the return variables.
643        my ($fileName, $genomeA, $genomeB);
644        # Determine the ordering of the genome IDs.
645        if (MustFlipGenomeIDs($genome1, $genome2)) {
646            ($genomeA, $genomeB) = ($genome2, $genome1);
647        } else {
648            ($genomeA, $genomeB) = ($genome1, $genome2);
649        }
650        # Insure the source organism has a subdirectory in the organism cache.
651        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
652        # Compute the name of the correspondence file for the appropriate target genome.
653        $fileName = "$orgDir/$genomeB";
654        # Return the results.
655        return ($fileName, $genomeA, $genomeB);
656    }
657    
658    
659    =head3 ComputeCorresopndenceDirectory
660    
661        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
662    
663    Return the name of the directory that would contain the correspondence files
664    for the specified genome.
665    
666    =over 4
667    
668    =item genome
669    
670    ID of the genome whose correspondence file directory is desired.
671    
672    =item RETURN
673    
674    Returns the name of the directory of interest.
675    
676    =back
677    
678    =cut
679    
680    sub ComputeCorrespondenceDirectory {
681        # Get the parameters.
682        my ($genome) = @_;
683        # Insure the source organism has a subdirectory in the organism cache.
684        my $retVal = "$FIG_Config::orgCache/$genome";
685        Tracer::Insure($retVal, 0777);
686        # Return it.
687        return $retVal;
688    }
689    
690    
691    =head3 CreateGeneCorrespondenceFile
692    
693        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
694    
695    Create a new gene correspondence file in the organism cache for the specified
696    genome correspondence. The name of the new file will be returned along with
697    an indicator of whether or not it is in the correct direction.
698    
699    =over 4
700    
701    =item genome1
702    
703    Source genome for the desired correspondence.
704    
705    =item genome2
706    
707    Target genome for the desired correspondence.
708    
709    =item RETURN
710    
711    Returns a two-element list. The first element is the name of the file containing the
712    correspondence, or C<undef> if an error occurred. The second element is TRUE
713    if the correspondence would be forward or FALSE if the file needs to be flipped.
714    
715    =back
716    
717    =cut
718    
719    sub CreateGeneCorrespondenceFile {
720        # Get the parameters.
721        my ($genome1, $genome2) = @_;
722        # Declare the return variables.
723        my ($fileName, $converse);
724        # Compute the ultimate name for the correspondence file.
725        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
726        $converse = ($genome1 ne $genomeA);
727        # Generate a temporary file name in the same directory. We'll build the temporary
728        # file and then rename it when we're done.
729        my $tempFileName = "$corrFileName.$$.tmp";
730        # This will be set to FALSE if we detect an error.
731        my $fileOK = 1;
732        # The file handles will be put in here.
733        my ($ih, $oh);
734        # Protect from errors.
735        eval {
736            # Open the temporary file for output.
737            $oh = Open(undef, ">$tempFileName");
738            # Open a pipe to get the correspondence data.
739            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
740            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
741            # Copy the pipe date into the temporary file.
742            while (! eof $ih) {
743                my $line = <$ih>;
744                print $oh $line;
745            }
746            # Close both files. If the close fails we need to know: it means there was a pipe
747            # error.
748            $fileOK &&= close $ih;
749            $fileOK &&= close $oh;
750        };
751        if ($@) {
752            # Here a fatal error of some sort occurred. We need to force the files closed.
753            close $ih if $ih;
754            close $oh if $oh;
755        } elsif ($fileOK) {
756            # Here everything worked. Try to rename the temporary file to the real
757            # file name.
758            if (rename $tempFileName, $corrFileName) {
759                # Everything is ok, fix the permissions and return the file name.
760                chmod 0664, $corrFileName;
761                $fileName = $corrFileName;
762                Trace("Created correspondence file $fileName.") if T(Corr => 3);
763            }
764        }
765        # If the temporary file exists, delete it.
766        if (-f $tempFileName) {
767            unlink $tempFileName;
768        }
769        # Return the results.
770        return ($fileName, $converse);
771    }
772    
773    
774    =head3 MustFlipGenomeIDs
775    
776        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
777    
778    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
779    order, they are stored in the converse order in correspondence files on the server.
780    This is a simple method that allows the caller to check for the need to flip.
781    
782    =over 4
783    
784    =item genome1
785    
786    ID of the proposed source genome.
787    
788    =item genome2
789    
790    ID of the proposed target genome.
791    
792    =item RETURN
793    
794    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
795    it would be stored as a source.
796    
797    =back
798    
799    =cut
800    
801    sub MustFlipGenomeIDs {
802        # Get the parameters.
803        my ($genome1, $genome2) = @_;
804        # Return an indication.
805        return ($genome1 gt $genome2);
806    }
807    
808    
809    =head3 ReadGeneCorrespondenceFile
810    
811        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
812    
813    Return the contents of the specified gene correspondence file in the form of
814    a list of lists, with backward correspondences filtered out. If the file is
815    for the converse of the desired correspondence, the columns will be reordered
816    automatically so that it looks as if the file were designed for the proper
817    direction.
818    
819    =over 4
820    
821    =item fileName
822    
823    The name of the gene correspondence file to read.
824    
825    =item converse (optional)
826    
827    TRUE if the file is for the converse of the desired correspondence, else FALSE.
828    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
829    meaning we want to use the file as it appears on disk.
830    
831    =item all (optional)
832    
833    TRUE if backward unidirectional correspondences should be included in the output.
834    The default is FALSE, in which case only forward and bidirectional correspondences
835    are included.
836    
837    =item RETURN
838    
839    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
840    If the file's contents are invalid or an error occurs, an undefined value will be
841    returned.
842    
843    =back
844    
845    =cut
846    
847    sub ReadGeneCorrespondenceFile {
848        # Get the parameters.
849        my ($fileName, $converse, $all) = @_;
850        # Declare the return variable. We will only put something in here if we are
851        # completely successful.
852        my $retVal;
853        # This value will be set to 1 if an error is detected.
854        my $error = 0;
855        # Try to open the file.
856        my $ih;
857        Trace("Reading correspondence file $fileName.") if T(3);
858        if (! open $ih, "<$fileName") {
859            # Here the open failed, so we have an error.
860            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
861            $error = 1;
862        }
863        # The gene correspondence list will be built in here.
864        my @corrList;
865        # This variable will be set to TRUE if we find a reverse correspondence somewhere
866        # in the file. Not finding one is an error.
867        my $reverseFound = 0;
868        # Loop until we hit the end of the file or an error occurs. We must check the error
869        # first in case the file handle failed to open.
870        while (! $error && ! eof $ih) {
871            # Get the current line.
872            my @row = Tracer::GetLine($ih);
873            # Get the correspondence direction and check for a reverse arrow.
874            $reverseFound = 1 if ($row[8] eq '<-');
875            # If we're in converse mode, reformat the line.
876            if ($converse) {
877                ReverseGeneCorrespondenceRow(\@row);
878            }
879            # Validate the row.
880            if (ValidateGeneCorrespondenceRow(\@row)) {
881                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
882                $error = 1;
883            }
884            # If this row is in the correct direction, keep it.
885            if ($all || $row[8] ne '<-') {
886                push @corrList, \@row;
887            }
888        }
889        # Close the input file.
890        close $ih;
891        # If we have no errors, keep the result.
892        if (! $error) {
893            $retVal = \@corrList;
894        }
895        # Return the result (if any).
896        return $retVal;
897    }
898    
899    =head3 ReverseGeneCorrespondenceRow
900    
901        ServerThing::ReverseGeneCorrespondenceRow($row)
902    
903    Convert a gene correspondence row to represent the converse correspondence. The
904    elements in the row will be reordered to represent a correspondence from the
905    target genome to the source genome.
906    
907    =over 4
908    
909    =item row
910    
911    Reference to a list containing a single row from a L</Gene Correspondence List>.
912    
913    =back
914    
915    =cut
916    
917    sub ReverseGeneCorrespondenceRow {
918        # Get the parameters.
919        my ($row) = @_;
920        # Flip the row in place.
921        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
922         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
923         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
924        # Flip the arrow.
925        $row->[8] = ARROW_FLIP->{$row->[8]};
926        # Flip the pairs.
927        my @elements = split /,/, $row->[3];
928        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
929    }
930    
931    =head3 ValidateGeneCorrespondenceRow
932    
933        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
934    
935    Validate a gene correspondence row. The numeric fields are checked to insure they
936    are numeric and the source and target gene IDs are validated. The return value will
937    indicate the number of errors found.
938    
939    =over 4
940    
941    =item row
942    
943    Reference to a list containing a single row from a L</Gene Correspondence List>.
944    
945    =item RETURN
946    
947    Returns the number of errors found in the row. A return of C<0> indicates the row
948    is valid.
949    
950    =back
951    
952    =cut
953    
954    sub ValidateGeneCorrespondenceRow {
955        # Get the parameters.
956        my ($row, $genome1, $genome2) = @_;
957        # Denote no errors have been found so far.
958        my $retVal = 0;
959        # Check for non-numeric values in the number columns.
960        for my $col (@{NUM_COLS()}) {
961            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
962                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
963                $retVal++;
964            }
965        }
966        # Check the gene IDs.
967        for my $col (0, 1) {
968            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
969                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
970                $retVal++;
971            }
972        }
973        # Verify the arrow.
974        unless (exists ARROW_FLIP->{$row->[8]}) {
975            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
976            $retVal++;
977        }
978        # Return the error count.
979        return $retVal;
980    }
981    
982    =head3 GetCorrespondenceData
983    
984        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
985    
986    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
987    list is in a file, it will be read. If the file does not exist, it may be created.
988    
989    =over 4
990    
991    =item genome1
992    
993    ID of the source genome.
994    
995    =item genome2
996    
997    ID of the target genome.
998    
999    =item passive
1000    
1001    If TRUE, then the correspondence file will not be created if it does not exist.
1002    
1003    =item full
1004    
1005    If TRUE, then both directions of the correspondence will be represented; otherwise, only
1006    correspondences from the source to the target (including bidirectional corresopndences)
1007    will be included.
1008    
1009    =item RETURN
1010    
1011    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
1012    undefined value if an error occurs or no file exists and passive mode was specified.
1013    
1014    =back
1015    
1016    =cut
1017    
1018    sub GetCorrespondenceData {
1019        # Get the parameters.
1020        my ($genome1, $genome2, $passive, $full) = @_;
1021        # Declare the return variable.
1022        my $retVal;
1023        # Check for a gene correspondence file.
1024        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1025        if ($fileName) {
1026            # Here we found one, so read it in.
1027            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1028        }
1029        # Were we successful?
1030        if (! defined $retVal) {
1031            # Here we either don't have a correspondence file, or the one that's there is
1032            # invalid. If we are NOT in passive mode, then this means we need to create
1033            # the file.
1034            if (! $passive) {
1035                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1036                # Now try reading the new file.
1037                if (defined $fileName) {
1038                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1039                }
1040            }
1041        }
1042        # Return the result.
1043        return $retVal;
1044    
1045    }
1046    
1047    
1048  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1049    
# Line 222  Line 1051 
1051    
1052  =head3 RunRequest  =head3 RunRequest
1053    
1054      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1055    
1056  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1057  object for the parameters.  object for the parameters.
# Line 231  Line 1060 
1060    
1061  =item cgi  =item cgi
1062    
1063  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1064    significant parameters are as follows.
1065    
1066    =over 8
1067    
1068    =item function
1069    
1070    Name of the function to run.
1071    
1072    =item args
1073    
1074    Parameters for the function.
1075    
1076    =item encoding
1077    
1078    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1079    by the Java interface).
1080    
1081    =back
1082    
1083    Certain unusual requests can come in outside of the standard function interface.
1084    These are indicated by special parameters that override all the others.
1085    
1086    =over 8
1087    
1088    =item pod
1089    
1090    Display a POD documentation module.
1091    
1092    =item code
1093    
1094    Display an example code file.
1095    
1096    =item file
1097    
1098    Transfer a file (not implemented).
1099    
1100    =back
1101    
1102  =item serverThing  =item serverThing
1103    
1104  Server object against which to run the request.  Server object against which to run the request.
1105    
1106    =item docURL
1107    
1108    URL to use for POD documentation requests.
1109    
1110  =back  =back
1111    
1112  =cut  =cut
# Line 244  Line 1114 
1114  sub RunRequest {  sub RunRequest {
1115      # Get the parameters.      # Get the parameters.
1116      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1117        # Make the CGI object available to the server.
1118        $serverThing->{cgi} = $cgi;
1119      # Determine the request type.      # Determine the request type.
1120      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1121          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1122            # Here we have a documentation request.
1123            if ($module eq 'ServerScripts') {
1124                # Here we list the server scripts.
1125                require ListServerScripts;
1126                ListServerScripts::main();
1127            } else {
1128                # In this case, we produce POD HTML.
1129          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1130            }
1131        } elsif ($cgi->param('code')) {
1132            # Here the user wants to see the code for one of our scripts.
1133            LineNumberize($cgi->param('code'));
1134      } elsif ($cgi->param('file')) {      } elsif ($cgi->param('file')) {
1135          # Here we have a file request. Process according to the type.          # Here we have a file request. Process according to the type.
1136          my $type = $cgi->param('file');          my $type = $cgi->param('file');
# Line 267  Line 1150 
1150          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1151          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1152          # Insure the function name is valid.          # Insure the function name is valid.
1153          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1154              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1155            } else {
1156                # Determing the encoding scheme. The default is YAML.
1157                my $encoding = $cgi->param('encoding') || 'yaml';
1158                # Optional callback for json encoded documents
1159                my $callback = $cgi->param('callback');
1160          # The parameter structure will go in here.          # The parameter structure will go in here.
1161          my $args;              my $args = {};
1162          # Start the timer.          # Start the timer.
1163          my $start = time();          my $start = time();
1164          # The output document goes in here.          # The output document goes in here.
1165          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1166          # Protect from errors.          # Protect from errors.
1167          eval {          eval {
1168              # Parse the arguments.                  # Here we parse the arguments. This is affected by the encoding parameter.
1169              $args = YAML::Load($cgi->param('args'));                  # Get the argument string.
1170                    my $argString = $cgi->param('args');
1171                    # Only proceed if we found one.
1172                    if ($argString) {
1173                        if ($encoding eq 'yaml') {
1174                            # Parse the arguments using YAML.
1175                            $args = YAML::Load($argString);
1176                        } elsif ($encoding eq 'json') {
1177                            # Parse the arguments using JSON.
1178                            Trace("Incoming string is:\n$argString") if T(3);
1179                            $args = JSON::Any->jsonToObj($argString);
1180                        } else {
1181                            Die("Invalid encoding type $encoding.");
1182                        }
1183                    }
1184          };          };
1185          # Check to make sure we got everything.          # Check to make sure we got everything.
1186          if ($@) {          if ($@) {
# Line 288  Line 1188 
1188          } elsif (! $function) {          } elsif (! $function) {
1189              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1190          } else {          } else {
1191              $document = eval("\$serverThing->$function(\$args)");                  # Insure we're connected to the correct database.
1192                    my $dbName = $cgi->param('dbName');
1193                    if ($dbName && exists $serverThing->{db}) {
1194                        ChangeDB($serverThing, $dbName);
1195                    }
1196                    # Run the request.
1197                    $document = eval { $serverThing->$function($args) };
1198              # If we have an error, create an error document.              # If we have an error, create an error document.
1199              if ($@) {              if ($@) {
1200                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1201                  Trace("Error encountered by service: $@") if T(2);                      Trace("Error encountered by service: $@") if T(0);
1202              } else {              } else {
1203                  # No error, so we output the result.                      # No error, so we output the result. Start with an HTML header.
1204                        if ($encoding eq 'yaml') {
1205                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1206                  my $string = YAML::Dump($document);                      } else {
1207                            print $cgi->header(-type => 'text/javascript');
1208                        }
1209                        # The nature of the output depends on the encoding type.
1210                        eval {
1211                            my $string;
1212                            if ($encoding eq 'yaml') {
1213                                $string = YAML::Dump($document);
1214                            } elsif(defined($callback)) {
1215                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1216                            } else {
1217                                $string = JSON::Any->objToJson($document);
1218                            }
1219                  print $string;                  print $string;
1220                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
1221                        };
1222                        if ($@) {
1223                            SendError($@, "Error encoding result.");
1224                            Trace("Error encoding result: $@") if T(0);
1225                        }
1226              }              }
1227          }          }
1228          # Stop the timer.          # Stop the timer.
1229          my $duration = int(time() - $start + 0.5);          my $duration = int(time() - $start + 0.5);
1230          Trace("Function executed in $duration seconds by task $$.") if T(2);              Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1231            }
1232      }      }
1233  }  }
1234    
# Line 399  Line 1324 
1324  }  }
1325    
1326    
1327    =head3 LineNumberize
1328    
1329        ServerThing::LineNumberize($module);
1330    
1331    Output the module line by line with line numbers
1332    
1333    =over 4
1334    
1335    =item module
1336    
1337    Name of the module to line numberized
1338    
1339    =back
1340    
1341    =cut
1342    
1343    sub LineNumberize {
1344        # Get the parameters.
1345        my ($module) = @_;
1346        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1347        # Start the output page.
1348        print CGI::header();
1349        print CGI::start_html(-title => 'Documentation Page',
1350                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1351        # Protect from errors.
1352        eval {
1353            if (-e $fks_path) {
1354                print "<pre>\n";
1355                my $i = 1;
1356                foreach my $line (`cat $fks_path`) {
1357                    print "$i.\t$line";
1358                    $i++;
1359                }
1360                print "</pre>\n";
1361            } else {
1362                print "File $fks_path not found";
1363            }
1364        };
1365        # Process any error.
1366        if ($@) {
1367            print CGI::blockquote({ class => 'error' }, $@);
1368        }
1369        # Close off the page.
1370        print CGI::end_html();
1371    
1372    }
1373    
1374  =head3 ProducePod  =head3 ProducePod
1375    
1376      ServerThing::ProducePod($module);      ServerThing::ProducePod($module);
# Line 420  Line 1392 
1392      my ($module) = @_;      my ($module) = @_;
1393      # Start the output page.      # Start the output page.
1394      print CGI::header();      print CGI::header();
1395      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1396                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1397      # Protect from errors.      # Protect from errors.
1398      eval {      eval {
1399          # We'll format the HTML text in here.          # We'll format the HTML text in here.
1400          require DocUtils;          require DocUtils;
1401          my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/servers.cgi?pod=");          my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
1402          # Output the POD HTML.          # Output the POD HTML.
1403          print $html;          print $html;
1404      };      };
# Line 491  Line 1463 
1463      # Get the parameters.      # Get the parameters.
1464      my ($message, $status) = @_;      my ($message, $status) = @_;
1465      Trace("Error \"$status\" $message") if T(2);      Trace("Error \"$status\" $message") if T(2);
1466        # Check for a DBserver error. These can be retried and get a special status
1467        # code.
1468        my $realStatus;
1469        if ($message =~ /DBServer Error:\s+/) {
1470            $realStatus = "503 $status";
1471        } else {
1472            $realStatus = "500 $status";
1473        }
1474      # Print the header and the status message.      # Print the header and the status message.
1475      print CGI::header(-type => 'text/plain',      print CGI::header(-type => 'text/plain',
1476                        -status => "500 $status");                        -status => $realStatus);
1477      # Print the detailed message.      # Print the detailed message.
1478      print $message;      print $message;
1479  }  }
1480    
1481    
1482    =head3 Log
1483    
1484        Log($msg);
1485    
1486    Write a message to the log. This is a temporary hack until we can figure out how to get
1487    normal tracing and error logging working.
1488    
1489    =over 4
1490    
1491    =item msg
1492    
1493    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1494    
1495    =back
1496    
1497    =cut
1498    
1499    sub Log {
1500        # Get the parameters.
1501        my ($msg) = @_;
1502        # Open the log file for appending.
1503        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1504        print $oh "$msg\n";
1505        close $oh;
1506    }
1507    
1508  1;  1;

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.72

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3