[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.54, Tue Jul 13 18:49:09 2010 UTC revision 1.72, Thu Mar 17 21:32:30 2011 UTC
# Line 40  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 53  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 305  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 425  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 679  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 771  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 938  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 990  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 997  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      my $module = $cgi->param('pod');      my $module = $cgi->param('pod');
1121      if ($module) {      if ($module) {
# Line 1031  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.          # Determing the encoding scheme. The default is YAML.
1157          my $encoding = $cgi->param('encoding') || 'yaml';          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.
# Line 1068  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 ($@) {
# Line 1075  Line 1201 
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. Start with an HTML header.                  # 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                        } else {
1207                            print $cgi->header(-type => 'text/javascript');
1208                        }
1209                  # The nature of the output depends on the encoding type.                  # The nature of the output depends on the encoding type.
1210                        eval {
1211                  my $string;                  my $string;
1212                  if ($encoding eq 'yaml') {                  if ($encoding eq 'yaml') {
1213                      $string = YAML::Dump($document);                      $string = YAML::Dump($document);
1214                            } elsif(defined($callback)) {
1215                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1216                  } else {                  } else {
1217                      $string = JSON::Any->objToJson($document);                      $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 1092  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 1340  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.54  
changed lines
  Added in v.1.72

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3