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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3