[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.71, Thu Mar 17 20:30:01 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.
66                  if ($ENV{REQUEST_METHOD} eq '') {                  if ($ENV{REQUEST_METHOD} eq '') {
67                      # Count the number of requests.                      # Count the number of requests.
68                      my $requests = 0;                      my $requests = 0;
69                      Trace("Starting Fast CGI loop.") if T(3);                      # 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                        open(SERVER_STDERR, ">", *STDERR);
74                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
75                             ($cgi = new CGI::Fast())) {                             ($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                            my $function = $cgi->param('function') || "<non-functional>"; #HACK
82                            # warn "Function request is $function in task $$.\n"; ##HACK
83                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
84                          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);
85                            *STDERR = *SAVED_STDERR;
86                      }                      }
87                      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);
88                        close(SERVER_STDERR);
89                  } else {                  } else {
90                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
91                      my $cgi = CGI->new();                      my $cgi = CGI->new();
# Line 97  Line 114 
114    
115  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
116    
117      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
118    
119  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
120  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
121  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
122  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
123  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
124    
125  =over 4  =over 4
126    
# Line 117  Line 134 
134  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
135  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
136    
137    =item roles
138    
139    If TRUE, role filtering will be applied. In this case, the default action
140    is to exclude auxiliary roles unless C<-aux> is TRUE.
141    
142  =back  =back
143    
144  =cut  =cut
# Line 127  Line 149 
149    
150  sub AddSubsystemFilter {  sub AddSubsystemFilter {
151      # Get the parameters.      # Get the parameters.
152      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
153      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
154      my @newFilters;      my @newFilters;
155      # 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 173 
173              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
174          }          }
175      }      }
176        # Check for role filtering.
177        if ($roles) {
178            # Here, we filter out auxiliary roles unless the user requests
179            # them.
180            if (! $args->{-aux}) {
181                push @newFilters, "Includes(auxiliary) = 0"
182            }
183        }
184      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
185      if (@newFilters) {      if (@newFilters) {
186          # 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 321 
321      }      }
322  }  }
323    
324    =head3 ReadCountVector
325    
326        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
327    
328    Extract a count vector from a query. The query can contain zero or more results,
329    and the vectors in the specified result field of the query must be concatenated
330    together in order. This method is optimized for the case (expected to be most
331    common) where there is only one result.
332    
333    =over 4
334    
335    =item qh
336    
337    Handle for the query from which results are to be extracted.
338    
339    =item field
340    
341    Name of the field containing the count vectors.
342    
343    =item rawFlag
344    
345    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
346    as reference to a list of numbers.
347    
348    =item RETURN
349    
350    Returns the desired vector, either encoded as a string or as a reference to a list
351    of numbers.
352    
353    =back
354    
355    =cut
356    
357    sub ReadCountVector {
358        # Get the parameters.
359        my ($qh, $field, $rawFlag) = @_;
360        # Declare the return variable.
361        my $retVal;
362        # Loop through the query results.
363        while (my $resultRow = $qh->Fetch()) {
364            # Get this vector.
365            my ($levelVector) = $resultRow->Value($field, $rawFlag);
366            # Is this the first result?
367            if (! defined $retVal) {
368                # Yes. Assign the result directly.
369                $retVal = $levelVector;
370            } elsif ($rawFlag) {
371                # This is a second result and the vectors are coded as strings.
372                $retVal .= $levelVector;
373            } else {
374                # This is a second result and the vectors are coded as array references.
375                push @$retVal, @$levelVector;
376            }
377        }
378        # Return the result.
379        return $retVal;
380    }
381    
382    =head3 ChangeDB
383    
384        ServerThing::ChangeDB($thing, $newDbName);
385    
386    Change the sapling database used by this server. The old database will be closed and a
387    new one attached.
388    
389    =over 4
390    
391    =item newDbName
392    
393    Name of the new Sapling database on which this server should operate. If omitted, the
394    default database will be used.
395    
396    =back
397    
398    =cut
399    
400    sub ChangeDB {
401        # Get the parameters.
402        my ($thing, $newDbName) = @_;
403        # Default the db-name if it's not specified.
404        if (! defined $newDbName) {
405            $newDbName = $FIG_Config::saplingDB;
406        }
407        # Check to see if we really need to change.
408        my $oldDB = $thing->{db};
409        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
410            # We need a new sapling.
411            require Sapling;
412            my $newDB = Sapling->new(dbName => $newDbName);
413            $thing->{db} = $newDB;
414        }
415    }
416    
417    
418  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
419    
# Line 665  Line 788 
788  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
789  it would be stored as a source.  it would be stored as a source.
790    
791    =back
792    
793  =cut  =cut
794    
795  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 757  Line 882 
882      }      }
883      # Close the input file.      # Close the input file.
884      close $ih;      close $ih;
885      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
886      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
887              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
888      }      }
889      # Return the result (if any).      # Return the result (if any).
890      return $retVal;      return $retVal;
# Line 852  Line 973 
973      return $retVal;      return $retVal;
974  }  }
975    
976    =head3 GetCorrespondenceData
977    
978        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
979    
980    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
981    list is in a file, it will be read. If the file does not exist, it may be created.
982    
983    =over 4
984    
985    =item genome1
986    
987    ID of the source genome.
988    
989    =item genome2
990    
991    ID of the target genome.
992    
993    =item passive
994    
995    If TRUE, then the correspondence file will not be created if it does not exist.
996    
997    =item full
998    
999    If TRUE, then both directions of the correspondence will be represented; otherwise, only
1000    correspondences from the source to the target (including bidirectional corresopndences)
1001    will be included.
1002    
1003    =item RETURN
1004    
1005    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
1006    undefined value if an error occurs or no file exists and passive mode was specified.
1007    
1008    =back
1009    
1010    =cut
1011    
1012    sub GetCorrespondenceData {
1013        # Get the parameters.
1014        my ($genome1, $genome2, $passive, $full) = @_;
1015        # Declare the return variable.
1016        my $retVal;
1017        # Check for a gene correspondence file.
1018        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1019        if ($fileName) {
1020            # Here we found one, so read it in.
1021            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1022        }
1023        # Were we successful?
1024        if (! defined $retVal) {
1025            # Here we either don't have a correspondence file, or the one that's there is
1026            # invalid. If we are NOT in passive mode, then this means we need to create
1027            # the file.
1028            if (! $passive) {
1029                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1030                # Now try reading the new file.
1031                if (defined $fileName) {
1032                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1033                }
1034            }
1035        }
1036        # Return the result.
1037        return $retVal;
1038    
1039    }
1040    
1041    
1042  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1043    
# Line 859  Line 1045 
1045    
1046  =head3 RunRequest  =head3 RunRequest
1047    
1048      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1049    
1050  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1051  object for the parameters.  object for the parameters.
# Line 868  Line 1054 
1054    
1055  =item cgi  =item cgi
1056    
1057  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1058    significant parameters are as follows.
1059    
1060    =over 8
1061    
1062    =item function
1063    
1064    Name of the function to run.
1065    
1066    =item args
1067    
1068    Parameters for the function.
1069    
1070    =item encoding
1071    
1072    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1073    by the Java interface).
1074    
1075    =back
1076    
1077    Certain unusual requests can come in outside of the standard function interface.
1078    These are indicated by special parameters that override all the others.
1079    
1080    =over 8
1081    
1082    =item pod
1083    
1084    Display a POD documentation module.
1085    
1086    =item code
1087    
1088    Display an example code file.
1089    
1090    =item file
1091    
1092    Transfer a file (not implemented).
1093    
1094    =back
1095    
1096  =item serverThing  =item serverThing
1097    
1098  Server object against which to run the request.  Server object against which to run the request.
1099    
1100    =item docURL
1101    
1102    URL to use for POD documentation requests.
1103    
1104  =back  =back
1105    
1106  =cut  =cut
# Line 881  Line 1108 
1108  sub RunRequest {  sub RunRequest {
1109      # Get the parameters.      # Get the parameters.
1110      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1111        # Make the CGI object available to the server.
1112        $serverThing->{cgi} = $cgi;
1113      # Determine the request type.      # Determine the request type.
1114      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1115          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1116            # Here we have a documentation request.
1117            if ($module eq 'ServerScripts') {
1118                # Here we list the server scripts.
1119                require ListServerScripts;
1120                ListServerScripts::main();
1121            } else {
1122                # In this case, we produce POD HTML.
1123          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1124            }
1125      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1126          # 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.
1127          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 907  Line 1144 
1144          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1145          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1146          # Insure the function name is valid.          # Insure the function name is valid.
1147          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1148              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1149            } else {
1150                # Determing the encoding scheme. The default is YAML.
1151                my $encoding = $cgi->param('encoding') || 'yaml';
1152                # Optional callback for json encoded documents
1153                my $callback = $cgi->param('callback');
1154          # The parameter structure will go in here.          # The parameter structure will go in here.
1155          my $args;              my $args = {};
1156          # Start the timer.          # Start the timer.
1157          my $start = time();          my $start = time();
1158          # The output document goes in here.          # The output document goes in here.
1159          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1160          # Protect from errors.          # Protect from errors.
1161          eval {          eval {
1162              # Parse the arguments.                  # Here we parse the arguments. This is affected by the encoding parameter.
1163              $args = YAML::Load($cgi->param('args'));                  # Get the argument string.
1164                    my $argString = $cgi->param('args');
1165                    # Only proceed if we found one.
1166                    if ($argString) {
1167                        if ($encoding eq 'yaml') {
1168                            # Parse the arguments using YAML.
1169                            $args = YAML::Load($argString);
1170                        } elsif ($encoding eq 'json') {
1171                            # Parse the arguments using JSON.
1172                            Trace("Incoming string is:\n$argString") if T(3);
1173                            $args = JSON::Any->jsonToObj($argString);
1174                        } else {
1175                            Die("Invalid encoding type $encoding.");
1176                        }
1177                    }
1178          };          };
1179          # Check to make sure we got everything.          # Check to make sure we got everything.
1180          if ($@) {          if ($@) {
# Line 928  Line 1182 
1182          } elsif (! $function) {          } elsif (! $function) {
1183              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1184          } else {          } else {
1185                    # Insure we're connected to the correct database.
1186                    my $dbName = $cgi->param('dbName');
1187                    if ($dbName && exists $serverThing->{db}) {
1188                        ChangeDB($serverThing, $dbName);
1189                    }
1190                    # Run the request.
1191              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1192              # If we have an error, create an error document.              # If we have an error, create an error document.
1193              if ($@) {              if ($@) {
1194                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1195                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1196              } else {              } else {
1197                  # No error, so we output the result.                      # No error, so we output the result. Start with an HTML header.
1198                        if ($encoding eq 'yaml') {
1199                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1200                  my $string = YAML::Dump($document);                      } else {
1201                            print $cgi->header(-type => 'text/javascript');
1202                        }
1203                        # The nature of the output depends on the encoding type.
1204                        eval {
1205                            my $string;
1206                            if ($encoding eq 'yaml') {
1207                                $string = YAML::Dump($document);
1208                            } elsif(defined($callback)) {
1209                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1210                            } else {
1211                                $string = JSON::Any->objToJson($document);
1212                            }
1213                  print $string;                  print $string;
1214                  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);
1215                        };
1216                        if ($@) {
1217                            SendError($@, "Error encoding result.");
1218                            Trace("Error encoding result: $@") if T(0);
1219                        }
1220              }              }
1221          }          }
1222          # Stop the timer.          # Stop the timer.
# Line 946  Line 1224 
1224          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1225      }      }
1226  }  }
1227    }
1228    
1229  =head3 CreateFile  =head3 CreateFile
1230    
# Line 1194  Line 1473 
1473  }  }
1474    
1475    
1476    =head3 Log
1477    
1478        Log($msg);
1479    
1480    Write a message to the log. This is a temporary hack until we can figure out how to get
1481    normal tracing and error logging working.
1482    
1483    =over 4
1484    
1485    =item msg
1486    
1487    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1488    
1489    =back
1490    
1491    =cut
1492    
1493    sub Log {
1494        # Get the parameters.
1495        my ($msg) = @_;
1496        # Open the log file for appending.
1497        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1498        print $oh "$msg\n";
1499        close $oh;
1500    }
1501    
1502  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3