[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.51, Wed Apr 28 15:46:38 2010 UTC revision 1.69, Wed Mar 16 15:57:16 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                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
74                             ($cgi = new CGI::Fast())) {                             ($cgi = new CGI::Fast())) {
75                            my $function = $cgi->param('function') || "<non-functional>"; #HACK
76                            warn "Function request is $function in task $$.\n"; ##HACK
77                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
78                          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);
79                      }                      }
80                      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);
81                  } else {                  } else {
82                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
83                      my $cgi = CGI->new();                      my $cgi = CGI->new();
# Line 98  Line 106 
106    
107  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
108    
109      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
110    
111  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
112  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
113  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
114  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
115  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
116    
117  =over 4  =over 4
118    
# Line 118  Line 126 
126  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
127  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
128    
129    =item roles
130    
131    If TRUE, role filtering will be applied. In this case, the default action
132    is to exclude auxiliary roles unless C<-aux> is TRUE.
133    
134  =back  =back
135    
136  =cut  =cut
# Line 128  Line 141 
141    
142  sub AddSubsystemFilter {  sub AddSubsystemFilter {
143      # Get the parameters.      # Get the parameters.
144      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
145      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
146      my @newFilters;      my @newFilters;
147      # 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 152  Line 165 
165              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
166          }          }
167      }      }
168        # Check for role filtering.
169        if ($roles) {
170            # Here, we filter out auxiliary roles unless the user requests
171            # them.
172            if (! $args->{-aux}) {
173                push @newFilters, "Includes(auxiliary) = 0"
174            }
175        }
176      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
177      if (@newFilters) {      if (@newFilters) {
178          # 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 292  Line 313 
313      }      }
314  }  }
315    
316    =head3 ReadCountVector
317    
318        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
319    
320    Extract a count vector from a query. The query can contain zero or more results,
321    and the vectors in the specified result field of the query must be concatenated
322    together in order. This method is optimized for the case (expected to be most
323    common) where there is only one result.
324    
325    =over 4
326    
327    =item qh
328    
329    Handle for the query from which results are to be extracted.
330    
331    =item field
332    
333    Name of the field containing the count vectors.
334    
335    =item rawFlag
336    
337    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
338    as reference to a list of numbers.
339    
340    =item RETURN
341    
342    Returns the desired vector, either encoded as a string or as a reference to a list
343    of numbers.
344    
345    =back
346    
347    =cut
348    
349    sub ReadCountVector {
350        # Get the parameters.
351        my ($qh, $field, $rawFlag) = @_;
352        # Declare the return variable.
353        my $retVal;
354        # Loop through the query results.
355        while (my $resultRow = $qh->Fetch()) {
356            # Get this vector.
357            my ($levelVector) = $resultRow->Value($field, $rawFlag);
358            # Is this the first result?
359            if (! defined $retVal) {
360                # Yes. Assign the result directly.
361                $retVal = $levelVector;
362            } elsif ($rawFlag) {
363                # This is a second result and the vectors are coded as strings.
364                $retVal .= $levelVector;
365            } else {
366                # This is a second result and the vectors are coded as array references.
367                push @$retVal, @$levelVector;
368            }
369        }
370        # Return the result.
371        return $retVal;
372    }
373    
374    =head3 ChangeDB
375    
376        ServerThing::ChangeDB($thing, $newDbName);
377    
378    Change the sapling database used by this server. The old database will be closed and a
379    new one attached.
380    
381    =over 4
382    
383    =item newDbName
384    
385    Name of the new Sapling database on which this server should operate. If omitted, the
386    default database will be used.
387    
388    =back
389    
390    =cut
391    
392    sub ChangeDB {
393        # Get the parameters.
394        my ($thing, $newDbName) = @_;
395        # Default the db-name if it's not specified.
396        if (! defined $newDbName) {
397            $newDbName = $FIG_Config::saplingDB;
398        }
399        # Check to see if we really need to change.
400        my $oldDB = $thing->{db};
401        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
402            # We need a new sapling.
403            require Sapling;
404            my $newDB = Sapling->new(dbName => $newDbName);
405            $thing->{db} = $newDB;
406        }
407    }
408    
409    
410  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
411    
# Line 666  Line 780 
780  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
781  it would be stored as a source.  it would be stored as a source.
782    
783    =back
784    
785  =cut  =cut
786    
787  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 758  Line 874 
874      }      }
875      # Close the input file.      # Close the input file.
876      close $ih;      close $ih;
877      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
878      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
879              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
880      }      }
881      # Return the result (if any).      # Return the result (if any).
882      return $retVal;      return $retVal;
# Line 853  Line 965 
965      return $retVal;      return $retVal;
966  }  }
967    
968    =head3 GetCorrespondenceData
969    
970        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
971    
972    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
973    list is in a file, it will be read. If the file does not exist, it may be created.
974    
975    =over 4
976    
977    =item genome1
978    
979    ID of the source genome.
980    
981    =item genome2
982    
983    ID of the target genome.
984    
985    =item passive
986    
987    If TRUE, then the correspondence file will not be created if it does not exist.
988    
989    =item full
990    
991    If TRUE, then both directions of the correspondence will be represented; otherwise, only
992    correspondences from the source to the target (including bidirectional corresopndences)
993    will be included.
994    
995    =item RETURN
996    
997    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
998    undefined value if an error occurs or no file exists and passive mode was specified.
999    
1000    =back
1001    
1002    =cut
1003    
1004    sub GetCorrespondenceData {
1005        # Get the parameters.
1006        my ($genome1, $genome2, $passive, $full) = @_;
1007        # Declare the return variable.
1008        my $retVal;
1009        # Check for a gene correspondence file.
1010        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1011        if ($fileName) {
1012            # Here we found one, so read it in.
1013            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1014        }
1015        # Were we successful?
1016        if (! defined $retVal) {
1017            # Here we either don't have a correspondence file, or the one that's there is
1018            # invalid. If we are NOT in passive mode, then this means we need to create
1019            # the file.
1020            if (! $passive) {
1021                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1022                # Now try reading the new file.
1023                if (defined $fileName) {
1024                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1025                }
1026            }
1027        }
1028        # Return the result.
1029        return $retVal;
1030    
1031    }
1032    
1033    
1034  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1035    
# Line 860  Line 1037 
1037    
1038  =head3 RunRequest  =head3 RunRequest
1039    
1040      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1041    
1042  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1043  object for the parameters.  object for the parameters.
# Line 912  Line 1089 
1089    
1090  Server object against which to run the request.  Server object against which to run the request.
1091    
1092    =item docURL
1093    
1094    URL to use for POD documentation requests.
1095    
1096  =back  =back
1097    
1098  =cut  =cut
# Line 919  Line 1100 
1100  sub RunRequest {  sub RunRequest {
1101      # Get the parameters.      # Get the parameters.
1102      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1103        # Make the CGI object available to the server.
1104        $serverThing->{cgi} = $cgi;
1105      # Determine the request type.      # Determine the request type.
1106      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1107          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1108            # Here we have a documentation request.
1109            if ($module eq 'ServerScripts') {
1110                # Here we list the server scripts.
1111                require ListServerScripts;
1112                ListServerScripts::main();
1113            } else {
1114                # In this case, we produce POD HTML.
1115          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1116            }
1117      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1118          # 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.
1119          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 945  Line 1136 
1136          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1137          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1138          # Insure the function name is valid.          # Insure the function name is valid.
1139          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1140              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1141            } else {
1142          # Determing the encoding scheme. The default is YAML.          # Determing the encoding scheme. The default is YAML.
1143          my $encoding = $cgi->param('encoding') || 'yaml';          my $encoding = $cgi->param('encoding') || 'yaml';
1144                # Optional callback for json encoded documents
1145                my $callback = $cgi->param('callback');
1146          # The parameter structure will go in here.          # The parameter structure will go in here.
1147          my $args;              my $args = {};
1148          # Start the timer.          # Start the timer.
1149          my $start = time();          my $start = time();
1150          # The output document goes in here.          # The output document goes in here.
1151          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1152          # Protect from errors.          # Protect from errors.
1153          eval {          eval {
1154              # Here we parse the arguments. This is affected by the encoding parameter.              # Here we parse the arguments. This is affected by the encoding parameter.
1155              # Get the argument string.              # Get the argument string.
1156              my $argString = $cgi->param('args');              my $argString = $cgi->param('args');
1157                    # Only proceed if we found one.
1158                    if ($argString) {
1159              if ($encoding eq 'yaml') {              if ($encoding eq 'yaml') {
1160                  # Parse the arguments using YAML.                  # Parse the arguments using YAML.
1161                  $args = YAML::Load($argString);                  $args = YAML::Load($argString);
# Line 972  Line 1166 
1166              } else {              } else {
1167                  Die("Invalid encoding type $encoding.");                  Die("Invalid encoding type $encoding.");
1168              }              }
1169                    }
1170          };          };
1171          # Check to make sure we got everything.          # Check to make sure we got everything.
1172          if ($@) {          if ($@) {
# Line 979  Line 1174 
1174          } elsif (! $function) {          } elsif (! $function) {
1175              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1176          } else {          } else {
1177                    # Insure we're connected to the correct database.
1178                    my $dbName = $cgi->param('dbName');
1179                    if ($dbName && exists $serverThing->{db}) {
1180                        ChangeDB($serverThing, $dbName);
1181                    }
1182                    # Run the request.
1183              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1184              # If we have an error, create an error document.              # If we have an error, create an error document.
1185              if ($@) {              if ($@) {
# Line 986  Line 1187 
1187                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1188              } else {              } else {
1189                  # No error, so we output the result. Start with an HTML header.                  # No error, so we output the result. Start with an HTML header.
1190                        if ($encoding eq 'yaml') {
1191                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1192                        } else {
1193                            print $cgi->header(-type => 'text/javascript');
1194                        }
1195                  # The nature of the output depends on the encoding type.                  # The nature of the output depends on the encoding type.
1196                        eval {
1197                  my $string;                  my $string;
1198                  if ($encoding eq 'yaml') {                  if ($encoding eq 'yaml') {
1199                      $string = YAML::Dump($document);                      $string = YAML::Dump($document);
1200                            } elsif(defined($callback)) {
1201                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1202                  } else {                  } else {
1203                      $string = JSON::Any->objToJson($document);                      $string = JSON::Any->objToJson($document);
1204                  }                  }
1205                  print $string;                  print $string;
1206                  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);
1207                        };
1208                        if ($@) {
1209                            SendError($@, "Error encoding result.");
1210                            Trace("Error encoding result: $@") if T(0);
1211                        }
1212              }              }
1213          }          }
1214          # Stop the timer.          # Stop the timer.
# Line 1003  Line 1216 
1216          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1217      }      }
1218  }  }
1219    }
1220    
1221  =head3 CreateFile  =head3 CreateFile
1222    
# Line 1251  Line 1465 
1465  }  }
1466    
1467    
1468    =head3 Log
1469    
1470        Log($msg);
1471    
1472    Write a message to the log. This is a temporary hack until we can figure out how to get
1473    normal tracing and error logging working.
1474    
1475    =over 4
1476    
1477    =item msg
1478    
1479    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1480    
1481    =back
1482    
1483    =cut
1484    
1485    sub Log {
1486        # Get the parameters.
1487        my ($msg) = @_;
1488        # Open the log file for appending.
1489        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1490        print $oh "$msg\n";
1491        close $oh;
1492    }
1493    
1494  1;  1;

Legend:
Removed from v.1.51  
changed lines
  Added in v.1.69

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3