[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.40, Tue Mar 16 20:24:05 2010 UTC revision 1.59, Tue Jan 11 15:03:02 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 => 5000;      use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
# Line 97  Line 98 
98    
99  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
100    
101      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
102    
103  Add subsystem filtering information to the specified query filter clause  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  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  the C<-usable> parameter, which includes or excludes unusuable subsystems,
106  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
107  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
108    
109  =over 4  =over 4
110    
# Line 117  Line 118 
118  Reference to the parameter hash for the current server call. This hash will  Reference to the parameter hash for the current server call. This hash will
119  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
120    
121    =item roles
122    
123    If TRUE, role filtering will be applied. In this case, the default action
124    is to exclude auxiliary roles unless C<-aux> is TRUE.
125    
126  =back  =back
127    
128  =cut  =cut
# Line 127  Line 133 
133    
134  sub AddSubsystemFilter {  sub AddSubsystemFilter {
135      # Get the parameters.      # Get the parameters.
136      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
137      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
138      my @newFilters;      my @newFilters;
139      # Unless unusable subsystems are desired, we must add a clause to the filter.      # Unless unusable subsystems are desired, we must add a clause to the filter.
# Line 151  Line 157 
157              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
158          }          }
159      }      }
160        # Check for role filtering.
161        if ($roles) {
162            # Here, we filter out auxiliary roles unless the user requests
163            # them.
164            if (! $args->{-aux}) {
165                push @newFilters, "Includes(auxiliary) = 0"
166            }
167        }
168      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
169      if (@newFilters) {      if (@newFilters) {
170          # Yes. If the incoming filter is nonempty, push it onto the list          # Yes. If the incoming filter is nonempty, push it onto the list
# Line 291  Line 305 
305      }      }
306  }  }
307    
308    =head3 ReadCountVector
309    
310        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
311    
312    Extract a count vector from a query. The query can contain zero or more results,
313    and the vectors in the specified result field of the query must be concatenated
314    together in order. This method is optimized for the case (expected to be most
315    common) where there is only one result.
316    
317    =over 4
318    
319    =item qh
320    
321    Handle for the query from which results are to be extracted.
322    
323    =item field
324    
325    Name of the field containing the count vectors.
326    
327    =item rawFlag
328    
329    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
330    as reference to a list of numbers.
331    
332    =item RETURN
333    
334    Returns the desired vector, either encoded as a string or as a reference to a list
335    of numbers.
336    
337    =back
338    
339    =cut
340    
341    sub ReadCountVector {
342        # Get the parameters.
343        my ($qh, $field, $rawFlag) = @_;
344        # Declare the return variable.
345        my $retVal;
346        # Loop through the query results.
347        while (my $resultRow = $qh->Fetch()) {
348            # Get this vector.
349            my ($levelVector) = $resultRow->Value($field, $rawFlag);
350            # Is this the first result?
351            if (! defined $retVal) {
352                # Yes. Assign the result directly.
353                $retVal = $levelVector;
354            } elsif ($rawFlag) {
355                # This is a second result and the vectors are coded as strings.
356                $retVal .= $levelVector;
357            } else {
358                # This is a second result and the vectors are coded as array references.
359                push @$retVal, @$levelVector;
360            }
361        }
362        # Return the result.
363        return $retVal;
364    }
365    
366    =head3 ChangeDB
367    
368        ServerThing::ChangeDB($thing, $newDbName);
369    
370    Change the sapling database used by this server. The old database will be closed and a
371    new one attached.
372    
373    =over 4
374    
375    =item newDbName
376    
377    Name of the new Sapling database on which this server should operate. If omitted, the
378    default database will be used.
379    
380    =back
381    
382    =cut
383    
384    sub ChangeDB {
385        # Get the parameters.
386        my ($thing, $newDbName) = @_;
387        # Default the db-name if it's not specified.
388        if (! defined $newDbName) {
389            $newDbName = $FIG_Config::saplingDB;
390        }
391        # Check to see if we really need to change.
392        my $oldDB = $thing->{db};
393        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
394            # We need a new sapling.
395            require Sapling;
396            my $newDB = Sapling->new(dbName => $newDbName);
397            $thing->{db} = $newDB;
398        }
399    }
400    
401    
402  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
403    
# Line 468  Line 575 
575      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
576      if (0 && -f $testFileName) {      if (0 && -f $testFileName) {
577          # Use the pre-computed file.          # Use the pre-computed file.
578          Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);          Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
579          $fileName = $testFileName;          $fileName = $testFileName;
580      } elsif (-f $corrFileName) {      } elsif (-f $corrFileName) {
581          $fileName = $corrFileName;          $fileName = $corrFileName;
582          Trace("Using cached file $fileName for genome correspondence.") if T(3);          Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
583      }      }
584      # Return the result.      # Return the result.
585      return ($fileName, $converse);      return ($fileName, $converse);
# Line 513  Line 620 
620      # Declare the return variables.      # Declare the return variables.
621      my ($fileName, $genomeA, $genomeB);      my ($fileName, $genomeA, $genomeB);
622      # Determine the ordering of the genome IDs.      # Determine the ordering of the genome IDs.
623      if ($genome1 lt $genome2) {      if (MustFlipGenomeIDs($genome1, $genome2)) {
         ($genomeA, $genomeB) = ($genome1, $genome2);  
     } else {  
624          ($genomeA, $genomeB) = ($genome2, $genome1);          ($genomeA, $genomeB) = ($genome2, $genome1);
625        } else {
626            ($genomeA, $genomeB) = ($genome1, $genome2);
627      }      }
628      # Insure the source organism has a subdirectory in the organism cache.      # Insure the source organism has a subdirectory in the organism cache.
629      my $orgDir = "$FIG_Config::orgCache/$genomeA";      my $orgDir = ComputeCorrespondenceDirectory($genomeA);
     Tracer::Insure($orgDir, 0777);  
630      # Compute the name of the correspondence file for the appropriate target genome.      # Compute the name of the correspondence file for the appropriate target genome.
631      $fileName = "$orgDir/$genomeB";      $fileName = "$orgDir/$genomeB";
632      # Return the results.      # Return the results.
# Line 528  Line 634 
634  }  }
635    
636    
637    =head3 ComputeCorresopndenceDirectory
638    
639        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
640    
641    Return the name of the directory that would contain the correspondence files
642    for the specified genome.
643    
644    =over 4
645    
646    =item genome
647    
648    ID of the genome whose correspondence file directory is desired.
649    
650    =item RETURN
651    
652    Returns the name of the directory of interest.
653    
654    =back
655    
656    =cut
657    
658    sub ComputeCorrespondenceDirectory {
659        # Get the parameters.
660        my ($genome) = @_;
661        # Insure the source organism has a subdirectory in the organism cache.
662        my $retVal = "$FIG_Config::orgCache/$genome";
663        Tracer::Insure($retVal, 0777);
664        # Return it.
665        return $retVal;
666    }
667    
668    
669  =head3 CreateGeneCorrespondenceFile  =head3 CreateGeneCorrespondenceFile
670    
671      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
# Line 599  Line 737 
737              # Everything is ok, fix the permissions and return the file name.              # Everything is ok, fix the permissions and return the file name.
738              chmod 0664, $corrFileName;              chmod 0664, $corrFileName;
739              $fileName = $corrFileName;              $fileName = $corrFileName;
740              Trace("Created correspondence file $fileName.") if T(3);              Trace("Created correspondence file $fileName.") if T(Corr => 3);
741          }          }
742      }      }
743      # If the temporary file exists, delete it.      # If the temporary file exists, delete it.
# Line 611  Line 749 
749  }  }
750    
751    
752    =head3 MustFlipGenomeIDs
753    
754        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
755    
756    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
757    order, they are stored in the converse order in correspondence files on the server.
758    This is a simple method that allows the caller to check for the need to flip.
759    
760    =over 4
761    
762    =item genome1
763    
764    ID of the proposed source genome.
765    
766    =item genome2
767    
768    ID of the proposed target genome.
769    
770    =item RETURN
771    
772    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
773    it would be stored as a source.
774    
775    =back
776    
777    =cut
778    
779    sub MustFlipGenomeIDs {
780        # Get the parameters.
781        my ($genome1, $genome2) = @_;
782        # Return an indication.
783        return ($genome1 gt $genome2);
784    }
785    
786    
787  =head3 ReadGeneCorrespondenceFile  =head3 ReadGeneCorrespondenceFile
788    
789      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
# Line 662  Line 835 
835      Trace("Reading correspondence file $fileName.") if T(3);      Trace("Reading correspondence file $fileName.") if T(3);
836      if (! open $ih, "<$fileName") {      if (! open $ih, "<$fileName") {
837          # Here the open failed, so we have an error.          # Here the open failed, so we have an error.
838          Trace("Failed to open gene correspondence file $fileName: $!") if T(3);          Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
839          $error = 1;          $error = 1;
840      }      }
841      # The gene correspondence list will be built in here.      # The gene correspondence list will be built in here.
# Line 683  Line 856 
856          }          }
857          # Validate the row.          # Validate the row.
858          if (ValidateGeneCorrespondenceRow(\@row)) {          if (ValidateGeneCorrespondenceRow(\@row)) {
859              Trace("Invalid row $. found in correspondence file $fileName.") if T(3);              Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
860              $error = 1;              $error = 1;
861          }          }
862          # If this row is in the correct direction, keep it.          # If this row is in the correct direction, keep it.
# Line 693  Line 866 
866      }      }
867      # Close the input file.      # Close the input file.
868      close $ih;      close $ih;
869      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
870      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
871              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(3);  
         }  
872      }      }
873      # Return the result (if any).      # Return the result (if any).
874      return $retVal;      return $retVal;
# Line 728  Line 897 
897      my ($row) = @_;      my ($row) = @_;
898      # Flip the row in place.      # Flip the row in place.
899      ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],      ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
900       $row->[6], ARROW_FLIP->{$row->[8]}, $row->[9], $row->[10], $row->[14],       $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
901       $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;       $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
902        # Flip the arrow.
903        $row->[8] = ARROW_FLIP->{$row->[8]};
904        # Flip the pairs.
905        my @elements = split /,/, $row->[3];
906        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
907  }  }
908    
909  =head3 ValidateGeneCorrespondenceRow  =head3 ValidateGeneCorrespondenceRow
# Line 763  Line 937 
937      # Check for non-numeric values in the number columns.      # Check for non-numeric values in the number columns.
938      for my $col (@{NUM_COLS()}) {      for my $col (@{NUM_COLS()}) {
939          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
940                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
941              $retVal++;              $retVal++;
942          }          }
943      }      }
944      # Check the gene IDs.      # Check the gene IDs.
945      for my $col (0, 1) {      for my $col (0, 1) {
946          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
947                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
948              $retVal++;              $retVal++;
949          }          }
950      }      }
951      # Verify the arrow.      # Verify the arrow.
952      unless (exists ARROW_FLIP->{$row->[8]}) {      unless (exists ARROW_FLIP->{$row->[8]}) {
953            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
954          $retVal++;          $retVal++;
955      }      }
956      # Return the error count.      # Return the error count.
957      return $retVal;      return $retVal;
958  }  }
959    
960    =head3 GetCorrespondenceData
961    
962        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
963    
964    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
965    list is in a file, it will be read. If the file does not exist, it may be created.
966    
967    =over 4
968    
969    =item genome1
970    
971    ID of the source genome.
972    
973    =item genome2
974    
975    ID of the target genome.
976    
977    =item passive
978    
979    If TRUE, then the correspondence file will not be created if it does not exist.
980    
981    =item full
982    
983    If TRUE, then both directions of the correspondence will be represented; otherwise, only
984    correspondences from the source to the target (including bidirectional corresopndences)
985    will be included.
986    
987    =item RETURN
988    
989    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
990    undefined value if an error occurs or no file exists and passive mode was specified.
991    
992    =back
993    
994    =cut
995    
996    sub GetCorrespondenceData {
997        # Get the parameters.
998        my ($genome1, $genome2, $passive, $full) = @_;
999        # Declare the return variable.
1000        my $retVal;
1001        # Check for a gene correspondence file.
1002        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1003        if ($fileName) {
1004            # Here we found one, so read it in.
1005            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1006        }
1007        # Were we successful?
1008        if (! defined $retVal) {
1009            # Here we either don't have a correspondence file, or the one that's there is
1010            # invalid. If we are NOT in passive mode, then this means we need to create
1011            # the file.
1012            if (! $passive) {
1013                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1014                # Now try reading the new file.
1015                if (defined $fileName) {
1016                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1017                }
1018            }
1019        }
1020        # Return the result.
1021        return $retVal;
1022    
1023    }
1024    
1025    
1026  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1027    
# Line 796  Line 1038 
1038    
1039  =item cgi  =item cgi
1040    
1041  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1042    significant parameters are as follows.
1043    
1044    =over 8
1045    
1046    =item function
1047    
1048    Name of the function to run.
1049    
1050    =item args
1051    
1052    Parameters for the function.
1053    
1054    =item encoding
1055    
1056    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1057    by the Java interface).
1058    
1059    =back
1060    
1061    Certain unusual requests can come in outside of the standard function interface.
1062    These are indicated by special parameters that override all the others.
1063    
1064    =over 8
1065    
1066    =item pod
1067    
1068    Display a POD documentation module.
1069    
1070    =item code
1071    
1072    Display an example code file.
1073    
1074    =item file
1075    
1076    Transfer a file (not implemented).
1077    
1078    =back
1079    
1080  =item serverThing  =item serverThing
1081    
# Line 810  Line 1089 
1089      # Get the parameters.      # Get the parameters.
1090      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1091      # Determine the request type.      # Determine the request type.
1092      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1093          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1094            # Here we have a documentation request.
1095            if ($module eq 'ServerScripts') {
1096                # Here we list the server scripts.
1097                require ListServerScripts;
1098                ListServerScripts::main();
1099            } else {
1100                # In this case, we produce POD HTML.
1101          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1102            }
1103      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1104          # Here the user wants to see the code for one of our scripts.          # Here the user wants to see the code for one of our scripts.
1105          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 837  Line 1124 
1124          # Insure the function name is valid.          # Insure the function name is valid.
1125          Die("Invalid function name.")          Die("Invalid function name.")
1126              if $function =~ /\W/;              if $function =~ /\W/;
1127            # Determing the encoding scheme. The default is YAML.
1128            my $encoding = $cgi->param('encoding') || 'yaml';
1129          # The parameter structure will go in here.          # The parameter structure will go in here.
1130          my $args;          my $args = {};
1131          # Start the timer.          # Start the timer.
1132          my $start = time();          my $start = time();
1133          # The output document goes in here.          # The output document goes in here.
1134          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1135          # Protect from errors.          # Protect from errors.
1136          eval {          eval {
1137              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
1138              $args = YAML::Load($cgi->param('args'));              # Get the argument string.
1139                my $argString = $cgi->param('args');
1140                # Only proceed if we found one.
1141                if ($argString) {
1142                    if ($encoding eq 'yaml') {
1143                        # Parse the arguments using YAML.
1144                        $args = YAML::Load($argString);
1145                    } elsif ($encoding eq 'json') {
1146                        # Parse the arguments using JSON.
1147                        Trace("Incoming string is:\n$argString") if T(3);
1148                        $args = JSON::Any->jsonToObj($argString);
1149                    } else {
1150                        Die("Invalid encoding type $encoding.");
1151                    }
1152                }
1153          };          };
1154          # Check to make sure we got everything.          # Check to make sure we got everything.
1155          if ($@) {          if ($@) {
# Line 856  Line 1157 
1157          } elsif (! $function) {          } elsif (! $function) {
1158              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1159          } else {          } else {
1160                # Insure we're connected to the correct database.
1161                my $dbName = $cgi->param('dbName');
1162                if ($dbName && exists $serverThing->{db}) {
1163                    ChangeDB($serverThing, $dbName);
1164                }
1165                # Run the request.
1166              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1167              # If we have an error, create an error document.              # If we have an error, create an error document.
1168              if ($@) {              if ($@) {
1169                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1170                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1171              } else {              } else {
1172                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1173                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1174                  my $string = YAML::Dump($document);                  # The nature of the output depends on the encoding type.
1175                    my $string;
1176                    if ($encoding eq 'yaml') {
1177                        $string = YAML::Dump($document);
1178                    } else {
1179                        $string = JSON::Any->objToJson($document);
1180                    }
1181                  print $string;                  print $string;
1182                  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);
1183              }              }
# Line 1035  Line 1348 
1348      my ($module) = @_;      my ($module) = @_;
1349      # Start the output page.      # Start the output page.
1350      print CGI::header();      print CGI::header();
1351      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1352                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1353      # Protect from errors.      # Protect from errors.
1354      eval {      eval {

Legend:
Removed from v.1.40  
changed lines
  Added in v.1.59

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3