[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.48, Fri Apr 16 21:39:51 2010 UTC revision 1.62, Wed Feb 9 17:56:09 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 39  Line 40 
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 97  Line 100 
100    
101  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
102    
103      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
104    
105  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
106  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
107  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
108  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
109  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
110    
111  =over 4  =over 4
112    
# Line 117  Line 120 
120  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
121  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
122    
123    =item roles
124    
125    If TRUE, role filtering will be applied. In this case, the default action
126    is to exclude auxiliary roles unless C<-aux> is TRUE.
127    
128  =back  =back
129    
130  =cut  =cut
# Line 127  Line 135 
135    
136  sub AddSubsystemFilter {  sub AddSubsystemFilter {
137      # Get the parameters.      # Get the parameters.
138      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
139      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
140      my @newFilters;      my @newFilters;
141      # 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 159 
159              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
160          }          }
161      }      }
162        # Check for role filtering.
163        if ($roles) {
164            # Here, we filter out auxiliary roles unless the user requests
165            # them.
166            if (! $args->{-aux}) {
167                push @newFilters, "Includes(auxiliary) = 0"
168            }
169        }
170      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
171      if (@newFilters) {      if (@newFilters) {
172          # 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 307 
307      }      }
308  }  }
309    
310    =head3 ReadCountVector
311    
312        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
313    
314    Extract a count vector from a query. The query can contain zero or more results,
315    and the vectors in the specified result field of the query must be concatenated
316    together in order. This method is optimized for the case (expected to be most
317    common) where there is only one result.
318    
319    =over 4
320    
321    =item qh
322    
323    Handle for the query from which results are to be extracted.
324    
325    =item field
326    
327    Name of the field containing the count vectors.
328    
329    =item rawFlag
330    
331    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
332    as reference to a list of numbers.
333    
334    =item RETURN
335    
336    Returns the desired vector, either encoded as a string or as a reference to a list
337    of numbers.
338    
339    =back
340    
341    =cut
342    
343    sub ReadCountVector {
344        # Get the parameters.
345        my ($qh, $field, $rawFlag) = @_;
346        # Declare the return variable.
347        my $retVal;
348        # Loop through the query results.
349        while (my $resultRow = $qh->Fetch()) {
350            # Get this vector.
351            my ($levelVector) = $resultRow->Value($field, $rawFlag);
352            # Is this the first result?
353            if (! defined $retVal) {
354                # Yes. Assign the result directly.
355                $retVal = $levelVector;
356            } elsif ($rawFlag) {
357                # This is a second result and the vectors are coded as strings.
358                $retVal .= $levelVector;
359            } else {
360                # This is a second result and the vectors are coded as array references.
361                push @$retVal, @$levelVector;
362            }
363        }
364        # Return the result.
365        return $retVal;
366    }
367    
368    =head3 ChangeDB
369    
370        ServerThing::ChangeDB($thing, $newDbName);
371    
372    Change the sapling database used by this server. The old database will be closed and a
373    new one attached.
374    
375    =over 4
376    
377    =item newDbName
378    
379    Name of the new Sapling database on which this server should operate. If omitted, the
380    default database will be used.
381    
382    =back
383    
384    =cut
385    
386    sub ChangeDB {
387        # Get the parameters.
388        my ($thing, $newDbName) = @_;
389        # Default the db-name if it's not specified.
390        if (! defined $newDbName) {
391            $newDbName = $FIG_Config::saplingDB;
392        }
393        # Check to see if we really need to change.
394        my $oldDB = $thing->{db};
395        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
396            # We need a new sapling.
397            require Sapling;
398            my $newDB = Sapling->new(dbName => $newDbName);
399            $thing->{db} = $newDB;
400        }
401    }
402    
403    
404  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
405    
# Line 665  Line 774 
774  Returns TRUE if the first genome would be stored on the server as a target, FALSE if  Returns TRUE if the first genome would be stored on the server as a target, FALSE if
775  it would be stored as a source.  it would be stored as a source.
776    
777    =back
778    
779  =cut  =cut
780    
781  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 757  Line 868 
868      }      }
869      # Close the input file.      # Close the input file.
870      close $ih;      close $ih;
871      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
872      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
873              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
874      }      }
875      # Return the result (if any).      # Return the result (if any).
876      return $retVal;      return $retVal;
# Line 852  Line 959 
959      return $retVal;      return $retVal;
960  }  }
961    
962    =head3 GetCorrespondenceData
963    
964        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
965    
966    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
967    list is in a file, it will be read. If the file does not exist, it may be created.
968    
969    =over 4
970    
971    =item genome1
972    
973    ID of the source genome.
974    
975    =item genome2
976    
977    ID of the target genome.
978    
979    =item passive
980    
981    If TRUE, then the correspondence file will not be created if it does not exist.
982    
983    =item full
984    
985    If TRUE, then both directions of the correspondence will be represented; otherwise, only
986    correspondences from the source to the target (including bidirectional corresopndences)
987    will be included.
988    
989    =item RETURN
990    
991    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
992    undefined value if an error occurs or no file exists and passive mode was specified.
993    
994    =back
995    
996    =cut
997    
998    sub GetCorrespondenceData {
999        # Get the parameters.
1000        my ($genome1, $genome2, $passive, $full) = @_;
1001        # Declare the return variable.
1002        my $retVal;
1003        # Check for a gene correspondence file.
1004        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1005        if ($fileName) {
1006            # Here we found one, so read it in.
1007            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1008        }
1009        # Were we successful?
1010        if (! defined $retVal) {
1011            # Here we either don't have a correspondence file, or the one that's there is
1012            # invalid. If we are NOT in passive mode, then this means we need to create
1013            # the file.
1014            if (! $passive) {
1015                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1016                # Now try reading the new file.
1017                if (defined $fileName) {
1018                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1019                }
1020            }
1021        }
1022        # Return the result.
1023        return $retVal;
1024    
1025    }
1026    
1027    
1028  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1029    
# Line 859  Line 1031 
1031    
1032  =head3 RunRequest  =head3 RunRequest
1033    
1034      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1035    
1036  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1037  object for the parameters.  object for the parameters.
# Line 868  Line 1040 
1040    
1041  =item cgi  =item cgi
1042    
1043  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1044    significant parameters are as follows.
1045    
1046    =over 8
1047    
1048    =item function
1049    
1050    Name of the function to run.
1051    
1052    =item args
1053    
1054    Parameters for the function.
1055    
1056    =item encoding
1057    
1058    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1059    by the Java interface).
1060    
1061    =back
1062    
1063    Certain unusual requests can come in outside of the standard function interface.
1064    These are indicated by special parameters that override all the others.
1065    
1066    =over 8
1067    
1068    =item pod
1069    
1070    Display a POD documentation module.
1071    
1072    =item code
1073    
1074    Display an example code file.
1075    
1076    =item file
1077    
1078    Transfer a file (not implemented).
1079    
1080    =back
1081    
1082  =item serverThing  =item serverThing
1083    
1084  Server object against which to run the request.  Server object against which to run the request.
1085    
1086    =item docURL
1087    
1088    URL to use for POD documentation requests.
1089    
1090  =back  =back
1091    
1092  =cut  =cut
# Line 881  Line 1094 
1094  sub RunRequest {  sub RunRequest {
1095      # Get the parameters.      # Get the parameters.
1096      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1097        # Make the CGI object available to the server.
1098        $serverThing->{cgi} = $cgi;
1099      # Determine the request type.      # Determine the request type.
1100      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1101          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1102            # Here we have a documentation request.
1103            if ($module eq 'ServerScripts') {
1104                # Here we list the server scripts.
1105                require ListServerScripts;
1106                ListServerScripts::main();
1107            } else {
1108                # In this case, we produce POD HTML.
1109          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1110            }
1111      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1112          # 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.
1113          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 909  Line 1132 
1132          # Insure the function name is valid.          # Insure the function name is valid.
1133          Die("Invalid function name.")          Die("Invalid function name.")
1134              if $function =~ /\W/;              if $function =~ /\W/;
1135            # Determing the encoding scheme. The default is YAML.
1136            my $encoding = $cgi->param('encoding') || 'yaml';
1137            # Optional callback for json encoded documents
1138            my $callback = $cgi->param('callback');
1139          # The parameter structure will go in here.          # The parameter structure will go in here.
1140          my $args;          my $args = {};
1141          # Start the timer.          # Start the timer.
1142          my $start = time();          my $start = time();
1143          # The output document goes in here.          # The output document goes in here.
1144          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1145          # Protect from errors.          # Protect from errors.
1146          eval {          eval {
1147              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
1148              $args = YAML::Load($cgi->param('args'));              # Get the argument string.
1149                my $argString = $cgi->param('args');
1150                # Only proceed if we found one.
1151                if ($argString) {
1152                    if ($encoding eq 'yaml') {
1153                        # Parse the arguments using YAML.
1154                        $args = YAML::Load($argString);
1155                    } elsif ($encoding eq 'json') {
1156                        # Parse the arguments using JSON.
1157                        Trace("Incoming string is:\n$argString") if T(3);
1158                        $args = JSON::Any->jsonToObj($argString);
1159                    } else {
1160                        Die("Invalid encoding type $encoding.");
1161                    }
1162                }
1163          };          };
1164          # Check to make sure we got everything.          # Check to make sure we got everything.
1165          if ($@) {          if ($@) {
# Line 928  Line 1167 
1167          } elsif (! $function) {          } elsif (! $function) {
1168              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1169          } else {          } else {
1170                # Insure we're connected to the correct database.
1171                my $dbName = $cgi->param('dbName');
1172                if ($dbName && exists $serverThing->{db}) {
1173                    ChangeDB($serverThing, $dbName);
1174                }
1175                # Run the request.
1176              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1177              # If we have an error, create an error document.              # If we have an error, create an error document.
1178              if ($@) {              if ($@) {
1179                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1180                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1181              } else {              } else {
1182                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1183                    if ($encoding eq 'yaml') {
1184                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1185                  my $string = YAML::Dump($document);                  } else {
1186                        print $cgi->header(-type => 'text/javascript');
1187                    }
1188                    # The nature of the output depends on the encoding type.
1189                    my $string;
1190                    if ($encoding eq 'yaml') {
1191                        $string = YAML::Dump($document);
1192                    } elsif(defined($callback)) {
1193                        $string = $callback . "(".JSON::Any->objToJson($document).")";
1194                    } else {
1195                        $string = JSON::Any->objToJson($document);
1196                    }
1197                  print $string;                  print $string;
1198                  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);
1199              }              }

Legend:
Removed from v.1.48  
changed lines
  Added in v.1.62

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3