[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.49, Wed Apr 28 14:02:11 2010 UTC revision 1.73, Thu Mar 31 20:03:07 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                            *STDERR = *SERVER_STDERR;
82                            my $function = $cgi->param('function') || "<non-functional>"; # (useful if we do tracing in here)
83                            # warn "Function request is $function in task $$.\n"; ##HACK
84                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
85                          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);
86                            *STDERR = *SAVED_STDERR;
87                      }                      }
88                      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);
89                        close(SERVER_STDERR);
90                  } else {                  } else {
91                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
92                      my $cgi = CGI->new();                      my $cgi = CGI->new();
# Line 97  Line 115 
115    
116  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
117    
118      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
119    
120  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
121  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
122  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
123  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
124  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
125    
126  =over 4  =over 4
127    
# Line 117  Line 135 
135  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
136  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
137    
138    =item roles
139    
140    If TRUE, role filtering will be applied. In this case, the default action
141    is to exclude auxiliary roles unless C<-aux> is TRUE.
142    
143  =back  =back
144    
145  =cut  =cut
# Line 127  Line 150 
150    
151  sub AddSubsystemFilter {  sub AddSubsystemFilter {
152      # Get the parameters.      # Get the parameters.
153      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
154      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
155      my @newFilters;      my @newFilters;
156      # 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 174 
174              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
175          }          }
176      }      }
177        # Check for role filtering.
178        if ($roles) {
179            # Here, we filter out auxiliary roles unless the user requests
180            # them.
181            if (! $args->{-aux}) {
182                push @newFilters, "Includes(auxiliary) = 0"
183            }
184        }
185      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
186      if (@newFilters) {      if (@newFilters) {
187          # 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 322 
322      }      }
323  }  }
324    
325    =head3 ReadCountVector
326    
327        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
328    
329    Extract a count vector from a query. The query can contain zero or more results,
330    and the vectors in the specified result field of the query must be concatenated
331    together in order. This method is optimized for the case (expected to be most
332    common) where there is only one result.
333    
334    =over 4
335    
336    =item qh
337    
338    Handle for the query from which results are to be extracted.
339    
340    =item field
341    
342    Name of the field containing the count vectors.
343    
344    =item rawFlag
345    
346    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
347    as reference to a list of numbers.
348    
349    =item RETURN
350    
351    Returns the desired vector, either encoded as a string or as a reference to a list
352    of numbers.
353    
354    =back
355    
356    =cut
357    
358    sub ReadCountVector {
359        # Get the parameters.
360        my ($qh, $field, $rawFlag) = @_;
361        # Declare the return variable.
362        my $retVal;
363        # Loop through the query results.
364        while (my $resultRow = $qh->Fetch()) {
365            # Get this vector.
366            my ($levelVector) = $resultRow->Value($field, $rawFlag);
367            # Is this the first result?
368            if (! defined $retVal) {
369                # Yes. Assign the result directly.
370                $retVal = $levelVector;
371            } elsif ($rawFlag) {
372                # This is a second result and the vectors are coded as strings.
373                $retVal .= $levelVector;
374            } else {
375                # This is a second result and the vectors are coded as array references.
376                push @$retVal, @$levelVector;
377            }
378        }
379        # Return the result.
380        return $retVal;
381    }
382    
383    =head3 ChangeDB
384    
385        ServerThing::ChangeDB($thing, $newDbName);
386    
387    Change the sapling database used by this server. The old database will be closed and a
388    new one attached.
389    
390    =over 4
391    
392    =item newDbName
393    
394    Name of the new Sapling database on which this server should operate. If omitted, the
395    default database will be used.
396    
397    =back
398    
399    =cut
400    
401    sub ChangeDB {
402        # Get the parameters.
403        my ($thing, $newDbName) = @_;
404        # Default the db-name if it's not specified.
405        if (! defined $newDbName) {
406            $newDbName = $FIG_Config::saplingDB;
407        }
408        # Check to see if we really need to change.
409        my $oldDB = $thing->{db};
410        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
411            # We need a new sapling.
412            require Sapling;
413            my $newDB = Sapling->new(dbName => $newDbName);
414            $thing->{db} = $newDB;
415        }
416    }
417    
418    
419  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
420    
# Line 411  Line 535 
535  Bit score for the match. Divide by the length of the longer PEG to get  Bit score for the match. Divide by the length of the longer PEG to get
536  what we often refer to as a "normalized bit score".  what we often refer to as a "normalized bit score".
537    
538    =item 18 (optional)
539    
540    Clear-correspondence indicator. If present, will be C<1> if the correspondence is a
541    clear bidirectional best hit (no similar candidates) and C<0> otherwise.
542    
543  =back  =back
544    
545  In the actual files, there will also be reverse correspondences indicated by a  In the actual files, there will also be reverse correspondences indicated by a
# Line 665  Line 794 
794  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
795  it would be stored as a source.  it would be stored as a source.
796    
797    =back
798    
799  =cut  =cut
800    
801  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 757  Line 888 
888      }      }
889      # Close the input file.      # Close the input file.
890      close $ih;      close $ih;
891      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
892      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
893              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
894      }      }
895      # Return the result (if any).      # Return the result (if any).
896      return $retVal;      return $retVal;
# Line 852  Line 979 
979      return $retVal;      return $retVal;
980  }  }
981    
982    =head3 GetCorrespondenceData
983    
984        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
985    
986    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
987    list is in a file, it will be read. If the file does not exist, it may be created.
988    
989    =over 4
990    
991    =item genome1
992    
993    ID of the source genome.
994    
995    =item genome2
996    
997    ID of the target genome.
998    
999    =item passive
1000    
1001    If TRUE, then the correspondence file will not be created if it does not exist.
1002    
1003    =item full
1004    
1005    If TRUE, then both directions of the correspondence will be represented; otherwise, only
1006    correspondences from the source to the target (including bidirectional corresopndences)
1007    will be included.
1008    
1009    =item RETURN
1010    
1011    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
1012    undefined value if an error occurs or no file exists and passive mode was specified.
1013    
1014    =back
1015    
1016    =cut
1017    
1018    sub GetCorrespondenceData {
1019        # Get the parameters.
1020        my ($genome1, $genome2, $passive, $full) = @_;
1021        # Declare the return variable.
1022        my $retVal;
1023        # Check for a gene correspondence file.
1024        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1025        if ($fileName) {
1026            # Here we found one, so read it in.
1027            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1028        }
1029        # Were we successful?
1030        if (! defined $retVal) {
1031            # Here we either don't have a correspondence file, or the one that's there is
1032            # invalid. If we are NOT in passive mode, then this means we need to create
1033            # the file.
1034            if (! $passive) {
1035                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1036                # Now try reading the new file.
1037                if (defined $fileName) {
1038                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1039                }
1040            }
1041        }
1042        # Return the result.
1043        return $retVal;
1044    
1045    }
1046    
1047    
1048  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1049    
# Line 859  Line 1051 
1051    
1052  =head3 RunRequest  =head3 RunRequest
1053    
1054      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1055    
1056  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1057  object for the parameters.  object for the parameters.
# Line 911  Line 1103 
1103    
1104  Server object against which to run the request.  Server object against which to run the request.
1105    
1106    =item docURL
1107    
1108    URL to use for POD documentation requests.
1109    
1110  =back  =back
1111    
1112  =cut  =cut
# Line 918  Line 1114 
1114  sub RunRequest {  sub RunRequest {
1115      # Get the parameters.      # Get the parameters.
1116      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1117        # Make the CGI object available to the server.
1118        $serverThing->{cgi} = $cgi;
1119      # Determine the request type.      # Determine the request type.
1120      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1121          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1122            # Here we have a documentation request.
1123            if ($module eq 'ServerScripts') {
1124                # Here we list the server scripts.
1125                require ListServerScripts;
1126                ListServerScripts::main();
1127            } else {
1128                # In this case, we produce POD HTML.
1129          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1130            }
1131      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1132          # 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.
1133          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 944  Line 1150 
1150          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1151          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1152          # Insure the function name is valid.          # Insure the function name is valid.
1153          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1154              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1155            } else {
1156                # Determing the encoding scheme. The default is YAML.
1157                my $encoding = $cgi->param('encoding') || 'yaml';
1158                # Optional callback for json encoded documents
1159                my $callback = $cgi->param('callback');
1160          # The parameter structure will go in here.          # The parameter structure will go in here.
1161          my $args;              my $args = {};
1162          # Start the timer.          # Start the timer.
1163          my $start = time();          my $start = time();
1164          # The output document goes in here.          # The output document goes in here.
1165          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1166          # Protect from errors.          # Protect from errors.
1167          eval {          eval {
1168              # Here we parse the arguments. This is affected by the encoding parameter.              # Here we parse the arguments. This is affected by the encoding parameter.
             # The default is YAML.  
             my $encoding = $cgi->param('encoding') || 'yaml';  
1169              # Get the argument string.              # Get the argument string.
1170              my $argString = $cgi->param('args');              my $argString = $cgi->param('args');
1171                    # Only proceed if we found one.
1172                    if ($argString) {
1173              if ($encoding eq 'yaml') {              if ($encoding eq 'yaml') {
1174                  # Parse the arguments using YAML.                  # Parse the arguments using YAML.
1175                  $args = YAML::Load($argString);                  $args = YAML::Load($argString);
1176              } elsif ($encoding eq 'json') {              } elsif ($encoding eq 'json') {
1177                  # Parse the arguments using JSON.                  # Parse the arguments using JSON.
1178                  require JSON::Any;                          Trace("Incoming string is:\n$argString") if T(3);
1179                  $args = JSON::Any->jsonToObj($argString);                  $args = JSON::Any->jsonToObj($argString);
1180              } else {              } else {
1181                  Die("Invalid encoding type $encoding.");                  Die("Invalid encoding type $encoding.");
1182              }              }
1183                    }
1184          };          };
1185          # Check to make sure we got everything.          # Check to make sure we got everything.
1186          if ($@) {          if ($@) {
# Line 978  Line 1188 
1188          } elsif (! $function) {          } elsif (! $function) {
1189              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1190          } else {          } else {
1191                    # Insure we're connected to the correct database.
1192                    my $dbName = $cgi->param('dbName');
1193                    if ($dbName && exists $serverThing->{db}) {
1194                        ChangeDB($serverThing, $dbName);
1195                    }
1196                    # Run the request.
1197              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1198              # If we have an error, create an error document.              # If we have an error, create an error document.
1199              if ($@) {              if ($@) {
1200                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1201                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1202              } else {              } else {
1203                  # No error, so we output the result.                      # No error, so we output the result. Start with an HTML header.
1204                        if ($encoding eq 'yaml') {
1205                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1206                  my $string = YAML::Dump($document);                      } else {
1207                            print $cgi->header(-type => 'text/javascript');
1208                        }
1209                        # The nature of the output depends on the encoding type.
1210                        eval {
1211                            my $string;
1212                            if ($encoding eq 'yaml') {
1213                                $string = YAML::Dump($document);
1214                            } elsif(defined($callback)) {
1215                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1216                            } else {
1217                                $string = JSON::Any->objToJson($document);
1218                            }
1219                  print $string;                  print $string;
1220                  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);
1221                        };
1222                        if ($@) {
1223                            SendError($@, "Error encoding result.");
1224                            Trace("Error encoding result: $@") if T(0);
1225                        }
1226              }              }
1227          }          }
1228          # Stop the timer.          # Stop the timer.
# Line 996  Line 1230 
1230          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1231      }      }
1232  }  }
1233    }
1234    
1235  =head3 CreateFile  =head3 CreateFile
1236    
# Line 1163  Line 1398 
1398      eval {      eval {
1399          # We'll format the HTML text in here.          # We'll format the HTML text in here.
1400          require DocUtils;          require DocUtils;
1401          my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");          my $html = DocUtils::ShowPod($module, "http://pubseed.theseed.org/sapling/server.cgi?pod=");
1402          # Output the POD HTML.          # Output the POD HTML.
1403          print $html;          print $html;
1404      };      };
# Line 1244  Line 1479 
1479  }  }
1480    
1481    
1482    =head3 Log
1483    
1484        Log($msg);
1485    
1486    Write a message to the log. This is a temporary hack until we can figure out how to get
1487    normal tracing and error logging working.
1488    
1489    =over 4
1490    
1491    =item msg
1492    
1493    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1494    
1495    =back
1496    
1497    =cut
1498    
1499    sub Log {
1500        # Get the parameters.
1501        my ($msg) = @_;
1502        # Open the log file for appending.
1503        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1504        print $oh "$msg\n";
1505        close $oh;
1506    }
1507    
1508  1;  1;

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.73

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3