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

Annotation of /FigWebServices/cluster_xmlrpc.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download)

1 : olson 1.1 use Frontier::RPC2;
2 :     use Cluster;
3 :    
4 :     use FIG;
5 :    
6 :     use strict;
7 :    
8 :     $| = 1; # Perl magic to use unbuffered output on standard output
9 :    
10 :     my $xml_rpc_server = Frontier::RPC2->new;
11 :    
12 :     my $fig = new FIG;
13 :    
14 :     #
15 :     # Create a list of the methods to be served
16 :     #
17 :    
18 :     my $methods = {
19 :     get_work => \&get_work,
20 :     work_done => \&work_done,
21 :     work_aborted => \&work_aborted,
22 :     };
23 :    
24 :     process_cgi_call($methods);
25 :    
26 :     exit 0;
27 :    
28 :     sub get_work
29 :     {
30 :     my($table, $worker) = @_;
31 :    
32 :     my $jobmgr = new Cluster::DBJobMgr($fig, $table);
33 :    
34 :     return $jobmgr->get_work($worker);
35 :     }
36 :    
37 :    
38 :     sub work_done
39 :     {
40 :     my($table, $work, $output) = @_;
41 :    
42 :     my $jobmgr = new Cluster::DBJobMgr($fig, $table);
43 :    
44 :     return $jobmgr->work_done($work, $output);
45 :     }
46 :    
47 :     sub work_aborted
48 :     {
49 :     my($table, $work) = @_;
50 :    
51 :     my $jobmgr = new Cluster::DBJobMgr($fig, $table);
52 :    
53 :     return $jobmgr->work_aborted($work);
54 :     }
55 :    
56 :    
57 :     #==========================================================================
58 :     # CGI Support
59 :     #==========================================================================
60 :     # Simple CGI support for Frontier::RPC2. You can copy this into your CGI
61 :     # scripts verbatim, or you can package it into a library.
62 :     # (Based on xmlrpc_cgi.c by Eric Kidd <http://xmlrpc-c.sourceforge.net/>.)
63 :    
64 :     # Process a CGI call.
65 :     sub process_cgi_call ($) {
66 :     my ($methods) = @_;
67 :    
68 :     # Get our CGI request information.
69 :     my $method = $ENV{'REQUEST_METHOD'};
70 :     my $type = $ENV{'CONTENT_TYPE'};
71 :     my $length = $ENV{'CONTENT_LENGTH'};
72 :    
73 :     # Perform some sanity checks.
74 :     http_error(405, "Method Not Allowed") unless $method eq "POST";
75 :     http_error(400, "Bad Request") unless $type eq "text/xml";
76 :     http_error(411, "Length Required") unless $length > 0;
77 :    
78 :     # Fetch our body.
79 :     my $body;
80 :     my $count = read STDIN, $body, $length;
81 :     http_error(400, "Bad Request") unless $count == $length;
82 :    
83 :     # Serve our request.
84 :     my $coder = Frontier::RPC2->new;
85 :     send_xml($coder->serve($body, $methods));
86 :     }
87 :    
88 :     # Send an HTTP error and exit.
89 :     sub http_error ($$) {
90 :     my ($code, $message) = @_;
91 :     print <<"EOD";
92 :     Status: $code $message
93 :     Content-type: text/html
94 :    
95 :     <title>$code $message</title>
96 :     <h1>$code $message</h1>
97 :     <p>Unexpected error processing XML-RPC request.</p>
98 :     EOD
99 :     exit 0;
100 :     }
101 :    
102 :     # Send an XML document (but don't exit).
103 :     sub send_xml ($) {
104 :     my ($xml_string) = @_;
105 :     my $length = length($xml_string);
106 :     print <<"EOD";
107 :     Status: 200 OK
108 :     Content-type: text/xml
109 :     Content-length: $length
110 :    
111 :     EOD
112 :     # We want precise control over whitespace here.
113 :     print $xml_string;
114 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3