[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.55, Thu Jul 29 17:35:51 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;
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 468  Line 482 
482      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
483      if (0 && -f $testFileName) {      if (0 && -f $testFileName) {
484          # Use the pre-computed file.          # Use the pre-computed file.
485          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);
486          $fileName = $testFileName;          $fileName = $testFileName;
487      } elsif (-f $corrFileName) {      } elsif (-f $corrFileName) {
488          $fileName = $corrFileName;          $fileName = $corrFileName;
489          Trace("Using cached file $fileName for genome correspondence.") if T(3);          Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
490      }      }
491      # Return the result.      # Return the result.
492      return ($fileName, $converse);      return ($fileName, $converse);
# Line 513  Line 527 
527      # Declare the return variables.      # Declare the return variables.
528      my ($fileName, $genomeA, $genomeB);      my ($fileName, $genomeA, $genomeB);
529      # Determine the ordering of the genome IDs.      # Determine the ordering of the genome IDs.
530      if ($genome1 lt $genome2) {      if (MustFlipGenomeIDs($genome1, $genome2)) {
         ($genomeA, $genomeB) = ($genome1, $genome2);  
     } else {  
531          ($genomeA, $genomeB) = ($genome2, $genome1);          ($genomeA, $genomeB) = ($genome2, $genome1);
532        } else {
533            ($genomeA, $genomeB) = ($genome1, $genome2);
534      }      }
535      # Insure the source organism has a subdirectory in the organism cache.      # Insure the source organism has a subdirectory in the organism cache.
536      my $orgDir = "$FIG_Config::orgCache/$genomeA";      my $orgDir = ComputeCorrespondenceDirectory($genomeA);
     Tracer::Insure($orgDir, 0777);  
537      # Compute the name of the correspondence file for the appropriate target genome.      # Compute the name of the correspondence file for the appropriate target genome.
538      $fileName = "$orgDir/$genomeB";      $fileName = "$orgDir/$genomeB";
539      # Return the results.      # Return the results.
# Line 528  Line 541 
541  }  }
542    
543    
544    =head3 ComputeCorresopndenceDirectory
545    
546        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
547    
548    Return the name of the directory that would contain the correspondence files
549    for the specified genome.
550    
551    =over 4
552    
553    =item genome
554    
555    ID of the genome whose correspondence file directory is desired.
556    
557    =item RETURN
558    
559    Returns the name of the directory of interest.
560    
561    =back
562    
563    =cut
564    
565    sub ComputeCorrespondenceDirectory {
566        # Get the parameters.
567        my ($genome) = @_;
568        # Insure the source organism has a subdirectory in the organism cache.
569        my $retVal = "$FIG_Config::orgCache/$genome";
570        Tracer::Insure($retVal, 0777);
571        # Return it.
572        return $retVal;
573    }
574    
575    
576  =head3 CreateGeneCorrespondenceFile  =head3 CreateGeneCorrespondenceFile
577    
578      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
# Line 599  Line 644 
644              # Everything is ok, fix the permissions and return the file name.              # Everything is ok, fix the permissions and return the file name.
645              chmod 0664, $corrFileName;              chmod 0664, $corrFileName;
646              $fileName = $corrFileName;              $fileName = $corrFileName;
647              Trace("Created correspondence file $fileName.") if T(3);              Trace("Created correspondence file $fileName.") if T(Corr => 3);
648          }          }
649      }      }
650      # If the temporary file exists, delete it.      # If the temporary file exists, delete it.
# Line 611  Line 656 
656  }  }
657    
658    
659    =head3 MustFlipGenomeIDs
660    
661        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
662    
663    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
664    order, they are stored in the converse order in correspondence files on the server.
665    This is a simple method that allows the caller to check for the need to flip.
666    
667    =over 4
668    
669    =item genome1
670    
671    ID of the proposed source genome.
672    
673    =item genome2
674    
675    ID of the proposed target genome.
676    
677    =item RETURN
678    
679    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
680    it would be stored as a source.
681    
682    =back
683    
684    =cut
685    
686    sub MustFlipGenomeIDs {
687        # Get the parameters.
688        my ($genome1, $genome2) = @_;
689        # Return an indication.
690        return ($genome1 gt $genome2);
691    }
692    
693    
694  =head3 ReadGeneCorrespondenceFile  =head3 ReadGeneCorrespondenceFile
695    
696      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
# Line 662  Line 742 
742      Trace("Reading correspondence file $fileName.") if T(3);      Trace("Reading correspondence file $fileName.") if T(3);
743      if (! open $ih, "<$fileName") {      if (! open $ih, "<$fileName") {
744          # Here the open failed, so we have an error.          # Here the open failed, so we have an error.
745          Trace("Failed to open gene correspondence file $fileName: $!") if T(3);          Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
746          $error = 1;          $error = 1;
747      }      }
748      # The gene correspondence list will be built in here.      # The gene correspondence list will be built in here.
# Line 683  Line 763 
763          }          }
764          # Validate the row.          # Validate the row.
765          if (ValidateGeneCorrespondenceRow(\@row)) {          if (ValidateGeneCorrespondenceRow(\@row)) {
766              Trace("Invalid row $. found in correspondence file $fileName.") if T(3);              Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
767              $error = 1;              $error = 1;
768          }          }
769          # If this row is in the correct direction, keep it.          # If this row is in the correct direction, keep it.
# Line 698  Line 778 
778          if ($reverseFound) {          if ($reverseFound) {
779              $retVal = \@corrList;              $retVal = \@corrList;
780          } else {          } else {
781              Trace("No reverse arrow found in correspondence file $fileName.") if T(3);              Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
782          }          }
783      }      }
784      # Return the result (if any).      # Return the result (if any).
# Line 728  Line 808 
808      my ($row) = @_;      my ($row) = @_;
809      # Flip the row in place.      # Flip the row in place.
810      ($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],
811       $row->[6], ARROW_FLIP->{$row->[8]}, $row->[9], $row->[10], $row->[14],       $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
812       $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;
813        # Flip the arrow.
814        $row->[8] = ARROW_FLIP->{$row->[8]};
815        # Flip the pairs.
816        my @elements = split /,/, $row->[3];
817        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
818  }  }
819    
820  =head3 ValidateGeneCorrespondenceRow  =head3 ValidateGeneCorrespondenceRow
# Line 763  Line 848 
848      # Check for non-numeric values in the number columns.      # Check for non-numeric values in the number columns.
849      for my $col (@{NUM_COLS()}) {      for my $col (@{NUM_COLS()}) {
850          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
851                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
852              $retVal++;              $retVal++;
853          }          }
854      }      }
855      # Check the gene IDs.      # Check the gene IDs.
856      for my $col (0, 1) {      for my $col (0, 1) {
857          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
858                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
859              $retVal++;              $retVal++;
860          }          }
861      }      }
862      # Verify the arrow.      # Verify the arrow.
863      unless (exists ARROW_FLIP->{$row->[8]}) {      unless (exists ARROW_FLIP->{$row->[8]}) {
864            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
865          $retVal++;          $retVal++;
866      }      }
867      # Return the error count.      # Return the error count.
868      return $retVal;      return $retVal;
869  }  }
870    
871    =head3 GetCorrespondenceData
872    
873        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
874    
875    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
876    list is in a file, it will be read. If the file does not exist, it may be created.
877    
878    =over 4
879    
880    =item genome1
881    
882    ID of the source genome.
883    
884    =item genome2
885    
886    ID of the target genome.
887    
888    =item passive
889    
890    If TRUE, then the correspondence file will not be created if it does not exist.
891    
892    =item full
893    
894    If TRUE, then both directions of the correspondence will be represented; otherwise, only
895    correspondences from the source to the target (including bidirectional corresopndences)
896    will be included.
897    
898    =item RETURN
899    
900    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
901    undefined value if an error occurs or no file exists and passive mode was specified.
902    
903    =back
904    
905    =cut
906    
907    sub GetCorrespondenceData {
908        # Get the parameters.
909        my ($genome1, $genome2, $passive, $full) = @_;
910        # Declare the return variable.
911        my $retVal;
912        # Check for a gene correspondence file.
913        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
914        if ($fileName) {
915            # Here we found one, so read it in.
916            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
917        }
918        # Were we successful?
919        if (! defined $retVal) {
920            # Here we either don't have a correspondence file, or the one that's there is
921            # invalid. If we are NOT in passive mode, then this means we need to create
922            # the file.
923            if (! $passive) {
924                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
925                # Now try reading the new file.
926                if (defined $fileName) {
927                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
928                }
929            }
930        }
931        # Return the result.
932        return $retVal;
933    
934    }
935    
936    
937  =head2 Internal Utility Methods  =head2 Internal Utility Methods
938    
# Line 796  Line 949 
949    
950  =item cgi  =item cgi
951    
952  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
953    significant parameters are as follows.
954    
955    =over 8
956    
957    =item function
958    
959    Name of the function to run.
960    
961    =item args
962    
963    Parameters for the function.
964    
965    =item encoding
966    
967    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
968    by the Java interface).
969    
970    =back
971    
972    Certain unusual requests can come in outside of the standard function interface.
973    These are indicated by special parameters that override all the others.
974    
975    =over 8
976    
977    =item pod
978    
979    Display a POD documentation module.
980    
981    =item code
982    
983    Display an example code file.
984    
985    =item file
986    
987    Transfer a file (not implemented).
988    
989    =back
990    
991  =item serverThing  =item serverThing
992    
# Line 810  Line 1000 
1000      # Get the parameters.      # Get the parameters.
1001      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1002      # Determine the request type.      # Determine the request type.
1003      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1004          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1005            # Here we have a documentation request.
1006            if ($module eq 'ServerScripts') {
1007                # Here we list the server scripts.
1008                require ListServerScripts;
1009                ListServerScripts::main();
1010            } else {
1011                # In this case, we produce POD HTML.
1012          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1013            }
1014      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1015          # 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.
1016          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 837  Line 1035 
1035          # Insure the function name is valid.          # Insure the function name is valid.
1036          Die("Invalid function name.")          Die("Invalid function name.")
1037              if $function =~ /\W/;              if $function =~ /\W/;
1038            # Determing the encoding scheme. The default is YAML.
1039            my $encoding = $cgi->param('encoding') || 'yaml';
1040          # The parameter structure will go in here.          # The parameter structure will go in here.
1041          my $args;          my $args = {};
1042          # Start the timer.          # Start the timer.
1043          my $start = time();          my $start = time();
1044          # The output document goes in here.          # The output document goes in here.
# Line 847  Line 1047 
1047          my $sapling;          my $sapling;
1048          # Protect from errors.          # Protect from errors.
1049          eval {          eval {
1050              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
1051              $args = YAML::Load($cgi->param('args'));              # Get the argument string.
1052                my $argString = $cgi->param('args');
1053                # Only proceed if we found one.
1054                if ($argString) {
1055                    if ($encoding eq 'yaml') {
1056                        # Parse the arguments using YAML.
1057                        $args = YAML::Load($argString);
1058                    } elsif ($encoding eq 'json') {
1059                        # Parse the arguments using JSON.
1060                        Trace("Incoming string is:\n$argString") if T(3);
1061                        $args = JSON::Any->jsonToObj($argString);
1062                    } else {
1063                        Die("Invalid encoding type $encoding.");
1064                    }
1065                }
1066          };          };
1067          # Check to make sure we got everything.          # Check to make sure we got everything.
1068          if ($@) {          if ($@) {
# Line 862  Line 1076 
1076                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1077                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1078              } else {              } else {
1079                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1080                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1081                  my $string = YAML::Dump($document);                  # The nature of the output depends on the encoding type.
1082                    my $string;
1083                    if ($encoding eq 'yaml') {
1084                        $string = YAML::Dump($document);
1085                    } else {
1086                        $string = JSON::Any->objToJson($document);
1087                    }
1088                  print $string;                  print $string;
1089                  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);
1090              }              }
# Line 1035  Line 1255 
1255      my ($module) = @_;      my ($module) = @_;
1256      # Start the output page.      # Start the output page.
1257      print CGI::header();      print CGI::header();
1258      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1259                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1260      # Protect from errors.      # Protect from errors.
1261      eval {      eval {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3