[Bio] / FigKernelPackages / ServerThing.pm Repository:
ViewVC logotype

View of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (download) (as text) (annotate)
Thu Dec 10 15:13:51 2009 UTC (10 years, 2 months ago) by parrello
Branch: MAIN
Changes since 1.23: +1 -0 lines
Trying to trace the FastCGI problem.

#!/usr/bin/perl -w

package ServerThing;

    use strict;
    use Tracer;
    use YAML;
    use ERDB;
    use TestUtils;
    use Time::HiRes;
    use File::Temp;
    use ErrorMessage;
    use CGI;
    no warnings qw(once);

    # Maximum number of requests to run per invocation.
    use constant MAX_REQUESTS => 500;

=head1 General Server Helper

This package provides a method-- I<RunServer>-- that can be called from a CGI
script to perform the duties of a FIG server. RunServer is called with two
parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
the first command-line parameter. The command-line parameter (if defined) will
be used as the tracing key, and also indicates that the script is being invoked
from the command line rather than over the web.

=cut

sub RunServer {
    # Get the parameters.
    my ($serverName, $key) = @_;
    # Turn off YAML compression, which causes problems with some of our hash keys.
    $YAML::CompressSeries = 0;
    # Create the server object.
    Trace("Requiring $serverName for task $$.") if T(3);
    eval {
        require "$serverName.pm";
    };
    # If we have an error, create an error document.
    if ($@) {
        SendError($@, "Could not load server module.");
    } else {
        # Having successfully loaded the server code, we create the object.
        my $serverThing = eval("$serverName" . '->new()');
        Trace("$serverName object created for task $$.") if T(2);
        # If we have an error, create an error document.
        if ($@) {
            SendError($@, "Could not start server.");
        } else {
            # No error, so now we can process the request.
            my $cgi;
            if (! defined $key) {
                # No tracing key, so presume we're a web service. Check for Fast CGI.
                if ($ENV{REQUEST_METHOD} eq '') {
                    # Here we're doing Fast CGI. In this case, the tracing key is the
                    # server name.
                    ETracing($serverName);
                    # Count the number of requests.
                    my $requests = 0;
                    Trace("Starting Fast CGI loop.") if T(3);
                    # Loop through the fast CGI requests. If we have request throttling,
                    # we exit after a maximum number of requests has been exceeded.
                    require CGI::Fast;
                    while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
                           ($cgi = new CGI::Fast())) {
                        RunRequest($cgi, $serverThing);
                        Trace("Request $requests complete in task $$.") if T(3);
                    }
                    Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
                } else {
                    # Here we have a normal web service (non-Fast).
                    my $cgi = CGI->new();
                    # Check for a source parameter. This gets used as the tracing key.
                    $key = $cgi->param('source');
                    if (! $key) {
                        # No source parameter, so do normal setup. Note we turn off
                        # CGI parameter tracing.
                        ETracing($cgi, 'noParms');
                    } else {
                        # Set up tracing using the specified key.
                        ETracing($key);
                    }
                    # Run this request.
                    RunRequest($cgi, $serverThing);
                }
            } else {
                # We're being invoked from the command line. Use the tracing
                # key to find the parm file and create the CGI object from that.
                my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
                $cgi = CGI->new($ih);
                # Set up tracing using the specified key.
                ETracing($key);
                # Run this request.
                RunRequest($cgi, $serverThing);
            }
        }
    }
}


=head2 Server Utility Methods

The methods in this section are utilities of general use to the various
server modules.

=head3 AddSubsystemFilter

    ServerThing::AddSubsystemFilter(\$filter, $args);

Add subsystem filtering information to the specified query filter clause
based on data in the argument hash. The argument hash will be checked for
the C<-usable> parameter, which includes or excludes unusuable subsystems, and
the C<-exclude> parameter, which lists types of subsystems that should be
excluded.

=over 4

=item filter

Reference to the current filter string. If additional filtering is required,
this string will be updated.

=item args

Reference to the parameter hash for the current server call. This hash will
be examined for the C<-usable> and C<-exclude> parameters.

=back

=cut

use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
                                         experimental   => 1,
                                         private        => 1 };

sub AddSubsystemFilter {
    # Get the parameters.
    my ($filter, $args) = @_;
    # We'll put the new filter stuff in here.
    my @newFilters;
    # Unless unusable subsystems are desired, we must add a clause to the filter.
    # The default is that only usable subsystems are included.
    my $usable = 1;
    # This default can be overridden by the "-usable" parameter.
    if (exists $args->{-usable}) {
        $usable = $args->{-usable};
    }
    # If we're restricting to usable subsystems, add a filter to that effect.
    if ($usable) {
        push @newFilters, "Subsystem(usable) = 1";
    }
    # Check for exclusion filters.
    my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
    for my $exclusion (@$exclusions) {
        if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
            Confess("Invalid exclusion type \"$exclusion\".");
        } else {
            # Here we have to exclude subsystems of the specified type.
            push @newFilters, "Subsystem($exclusion) = 0";
        }
    }
    # Do we need to update the incoming filter?
    if (@newFilters) {
        # Yes. If the incoming filter is nonempty, push it onto the list
        # so it gets included in the result.
        if ($$filter) {
            push @newFilters, $$filter;
        }
        # Put all the filters together to form the new filter.
        $$filter = join(" AND ", @newFilters);
        Trace("Subsystem filter is $$filter.") if T(3);
    }
}



=head3 GetIdList

    my $ids = ServerThing::GetIdList($name => $args, $optional);

Get a named list of IDs from an argument structure. If the IDs are
missing, or are not a list, an error will occur.

=over 4

=item name

Name of the argument structure member that should contain the ID list.

=item args

Argument structure from which the ID list is to be extracted.

=item optional (optional)

If TRUE, then a missing value will not generate an error. Instead, an empty list
will be returned. The default is FALSE.

=item RETURN

Returns a reference to a list of IDs taken from the argument structure.

=back

=cut

sub GetIdList {
    # Get the parameters.
    my ($name, $args, $optional) = @_;
    # Try to get the IDs from the argument structure.
    my $retVal = $args->{$name};
    # Was a member found?
    if (! defined $retVal) {
        # No. If we're optional, return an empty list; otherwise throw an error.
        if ($optional) {
            $retVal = [];
        } else {
            Confess("No '$name' parameter found.");
        }
    } else {
        # Here we found something. Get the parameter type. We was a list reference.
        # If it's a scalar, we'll convert it to a singleton list. If it's anything
        # else, it's an error.
        my $type = ref $retVal;
        if (! $type) {
            $retVal = [$retVal];
        } elsif ($type ne 'ARRAY') {
            Confess("The '$name' parameter must be a list.");
        }
    }
    # Return the result.
    return $retVal;
}


=head3 RunTool

    ServerThing::RunTool($name => $cmd);

Run a command-line tool. A non-zero return value from the tool will cause
a fatal error, and the tool's error log will be traced.

=over 4

=item name

Name to give to the tool in the error output.

=item cmd

Command to use for running the tool. This should be the complete command line.
The command should not contain any fancy piping, though it may redirect the
standard input and output. The command will be modified by this method to
redirect the error output to a temporary file.

=back

=cut

sub RunTool {
    # Get the parameters.
    my ($name, $cmd) = @_;
    # Compute the log file name.
    my $errorLog = "$FIG_Config::temp/errors$$.log";
    # Execute the command.
    Trace("Executing command: $cmd") if T(3);
    my $res = system("$cmd 2> $errorLog");
    Trace("Return from $name tool is $res.") if T(3);
    # Check the result code.
    if ($res != 0) {
        # We have an error. If tracing is on, trace it.
        if (T(1)) {
            TraceErrorLog($name, $errorLog);
        }
        # Delete the error log.
        unlink $errorLog;
        # Confess the error.
        Confess("$name command failed with error code $res.");
    } else {
        # Everything worked. Trace the error log if necessary.
        if (T(3) && -s $errorLog) {
            TraceErrorLog($name, $errorLog);
        }
        # Delete the error log if there is one.
        unlink $errorLog;
    }
}


=head2 Internal Utility Methods

The methods in this section are used internally by this package.

=head3 RunRequest

    ServerThing::RunRequest($cgi, $serverName);

Run a request from the specified server using the incoming CGI parameter
object for the parameters.

=over 4

=item cgi

CGI query object containing the parameters from the web service request.

=item serverThing

Server object against which to run the request.

=back

=cut

sub RunRequest {
    # Get the parameters.
    my ($cgi, $serverThing, $docURL) = @_;
    # Determine the request type.
    if ($cgi->param('pod')) {
        # Here we have a documentation request. In this case, we produce POD HTML.
        ProducePod($cgi->param('pod'));
    } elsif ($cgi->param('file')) {
        # Here we have a file request. Process according to the type.
        my $type = $cgi->param('file');
        if ($type eq 'open') {
            OpenFile($cgi->param('name'));
        } elsif ($type eq 'create') {
            CreateFile();
        } elsif ($type eq 'read') {
            ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
        } elsif ($type eq 'write') {
            WriteChunk($cgi->param('name'), $cgi->param('data'));
        } else {
            Die("Invalid file function \"$type\".");
        }
    } else {
        # The default is a function request. Get the function name.
        my $function = $cgi->param('function') || "";
        Trace("Server function for task $$ is $function.") if T(3);
        # Insure the function name is valid.
        Die("Invalid function name.")
            if $function =~ /\W/;
        # The parameter structure will go in here.
        my $args;
        # Start the timer.
        my $start = time();
        # The output document goes in here.
        my $document;
        # The sapling database goes in here.
        my $sapling;
        # Protect from errors.
        eval {
            # Parse the arguments.
            $args = YAML::Load($cgi->param('args'));
        };
        # Check to make sure we got everything.
        if ($@) {
            SendError($@, "Error formatting parameters.");
        } elsif (! $function) {
            SendError("No function specified.", "No function specified.");
        } else {
            $document = eval("\$serverThing->$function(\$args)");
            # If we have an error, create an error document.
            if ($@) {
                SendError($@, "Error detected by service.");
                Trace("Error encountered by service: $@") if T(2);
            } else {
                # No error, so we output the result.
                print $cgi->header(-type => 'text/plain');
                my $string = YAML::Dump($document);
                print $string;
                MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
            }
        }
        # Stop the timer.
        my $duration = int(time() - $start + 0.5);
        Trace("Function executed in $duration seconds by task $$.") if T(2);
    }
}

=head3 CreateFile

    ServerThing::CreateFile();

Create a new, empty temporary file and send its name back to the client.

=cut

sub CreateFile {
    ##TODO: Code
}

=head3 OpenFile

    ServerThing::OpenFile($name);

Send the length of the named file back to the client.

=over 4

=item name

##TODO: name description

=back

=cut

sub OpenFile {
    # Get the parameters.
    my ($name) = @_;
    ##TODO: Code
}

=head3 ReadChunk

    ServerThing::ReadChunk($name, $location, $size);

Read the indicated number of bytes from the specified location of the
named file and send them back to the client.

=over 4

=item name

##TODO: name description

=item location

##TODO: location description

=item size

##TODO: size description

=back

=cut

sub ReadChunk {
    # Get the parameters.
    my ($name, $location, $size) = @_;
    ##TODO: Code
}

=head3 WriteChunk

    ServerThing::WriteChunk($name, $data);

Write the specified data to the named file.

=over 4

=item name

##TODO: name description

=item data

##TODO: data description

=back

=cut

sub WriteChunk {
    # Get the parameters.
    my ($name, $data) = @_;
    ##TODO: Code
}


=head3 ProducePod

    ServerThing::ProducePod($module);

Output the POD documentation for the specified module.

=over 4

=item module

Name of the module whose POD document is to be displayed.

=back

=cut

sub ProducePod {
    # Get the parameters.
    my ($module) = @_;
    # Start the output page.
    print CGI::header();
    print CGI::start_html(-title => 'Documentation Page',
                          -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
    # Protect from errors.
    eval {
        # We'll format the HTML text in here.
        require DocUtils;
        my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
        # Output the POD HTML.
        print $html;
    };
    # Process any error.
    if ($@) {
        print CGI::blockquote({ class => 'error' }, $@);
    }
    # Close off the page.
    print CGI::end_html();

}

=head3 TraceErrorLog

    ServerThing::TraceErrorLog($name, $errorLog);

Trace the specified error log file. This is a very dinky routine that
performs a task required by L</RunTool> in multiple places.

=over 4

=item name

Name of the tool relevant to the log file.

=item errorLog

Name of the log file.

=back

=cut

sub TraceErrorLog {
    my ($name, $errorLog) = @_;
    my $errorData = Tracer::GetFile($errorLog);
    Trace("$name error log:\n$errorData");
}

=head3 SendError

    ServerThing::SendError($message, $status);

Fail an HTTP request with the specified error message and the specified
status message.

=over 4

=item message

Detailed error message. This is sent as the page content.

=item status

Status message. This is sent as part of the status code.

=back

=cut

sub SendError {
    # Get the parameters.
    my ($message, $status) = @_;
    Trace("Error \"$status\" $message") if T(2);
    # Print the header and the status message.
    print CGI::header(-type => 'text/plain',
                      -status => "500 $status");
    # Print the detailed message.
    print $message;
}


1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3