[Bio] / FigWebServices / cluster_xmlrpc.cgi Repository:
ViewVC logotype

View of /FigWebServices/cluster_xmlrpc.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (download) (annotate)
Thu Feb 10 16:56:24 2005 UTC (14 years, 10 months ago) by olson
Branch: MAIN
CVS Tags: merge-trunktag-bobdev_news-2, Root-bobdev_news, merge-bobdev_news-1, merge-trunktag-bobdev_news-1, merge-bodev_news-3, caBIG-00-00-00, merge-bobdev_news-2, merge-trunktag-bodev_news-3
Branch point for: Branch-bobdev_news
XMLRPC interface to cluster job mgr.

use Frontier::RPC2;
use Cluster;

use FIG;

use strict;

$| = 1;  # Perl magic to use unbuffered output on standard output

my $xml_rpc_server = Frontier::RPC2->new;

my $fig = new FIG;

#
# Create a list of the methods to be served
#

my $methods = {
    get_work => \&get_work,
    work_done => \&work_done,
    work_aborted => \&work_aborted,
};

process_cgi_call($methods);

exit 0;

sub get_work
{
    my($table, $worker) = @_;

    my $jobmgr = new Cluster::DBJobMgr($fig, $table);

    return $jobmgr->get_work($worker);
}


sub work_done
{
    my($table, $work, $output) = @_;

    my $jobmgr = new Cluster::DBJobMgr($fig, $table);

    return $jobmgr->work_done($work, $output);
}

sub work_aborted
{
    my($table, $work) = @_;

    my $jobmgr = new Cluster::DBJobMgr($fig, $table);

    return $jobmgr->work_aborted($work);
}


#==========================================================================
#  CGI Support
#==========================================================================
#  Simple CGI support for Frontier::RPC2. You can copy this into your CGI
#  scripts verbatim, or you can package it into a library.
#  (Based on xmlrpc_cgi.c by Eric Kidd <http://xmlrpc-c.sourceforge.net/>.)

# Process a CGI call.
sub process_cgi_call ($) {
    my ($methods) = @_;

    # Get our CGI request information.
    my $method = $ENV{'REQUEST_METHOD'};
    my $type = $ENV{'CONTENT_TYPE'};
    my $length = $ENV{'CONTENT_LENGTH'};

    # Perform some sanity checks.
    http_error(405, "Method Not Allowed") unless $method eq "POST";
    http_error(400, "Bad Request") unless $type eq "text/xml";
    http_error(411, "Length Required") unless $length > 0;

    # Fetch our body.
    my $body;
    my $count = read STDIN, $body, $length;
    http_error(400, "Bad Request") unless $count == $length; 

    # Serve our request.
    my $coder = Frontier::RPC2->new;
    send_xml($coder->serve($body, $methods));
}

# Send an HTTP error and exit.
sub http_error ($$) {
    my ($code, $message) = @_;
    print <<"EOD";
Status: $code $message
Content-type: text/html

<title>$code $message</title>
<h1>$code $message</h1>
<p>Unexpected error processing XML-RPC request.</p>
EOD
    exit 0;
}

# Send an XML document (but don't exit).
sub send_xml ($) {
    my ($xml_string) = @_;
    my $length = length($xml_string);
    print <<"EOD";
Status: 200 OK
Content-type: text/xml
Content-length: $length

EOD
    # We want precise control over whitespace here.
    print $xml_string;
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3