source: preprover/XMLRPC.pm @ 8200a9c

Last change on this file since 8200a9c was 6159c8d, checked in by Mike Ryan <mikeryan@…>, 14 years ago

add options to preprover client/server, install into bin

  • Property mode set to 100644
File size: 2.5 KB
Line 
1package XMLRPC;
2
3use strict;
4use Carp;
5
6use HTTP::Daemon::SSL;
7use HTTP::Status qw(:constants);
8use RPC::XML::Server;
9use Net::SSLeay;
10
11sub new {
12    my ($class) = @_;
13
14    my $srv = RPC::XML::Server->new(no_http => 1);
15    return bless \$srv, $class;
16}
17
18sub add_method {
19    my $self = shift;
20    my $srv = $$self;
21    $srv->add_method(@_);
22}
23
24sub verify {
25    my ($ok, $store_ctx) = @_;
26
27    my $x = Net::SSLeay::X509_STORE_CTX_get_current_cert($store_ctx);
28    return $x ? 1 : 0;
29}
30
31sub run {
32    my ($self, $port, $cert, $key) = @_;
33    croak "Must supply a port to run on" unless defined $port;
34    croak "Must give cert" unless defined $cert;
35    croak "Must give key" unless defined $key;
36
37    my $srv = $$self;
38
39    my $daemon = HTTP::Daemon::SSL->new(
40        LocalPort   => $port,
41        ReuseAddr   => 1,
42        SSL_key_file => $key,
43        SSL_certy_file => $cert,
44        SSL_verify_mode => 3,
45        SSL_ca_path => 'FAIL',  # if this isn't here, verify never gets called :D
46        SSL_verify_callback => \&verify,
47    ) or die "Can't start HTTP daemon: $!";
48
49    for ( ; ; ) {
50        while (my $client = $daemon->accept) {
51            my $pid = fork;
52            next if $pid;
53
54            my $peer_cert = $client->peer_certificate;
55            $srv->{peer_cert} = $peer_cert;
56
57            while (my $request = $client->get_request) {
58                # require an SSL certificate
59                if (!defined $srv->{peer_cert}) {
60                    my $response = HTTP::Response->new(HTTP_UNAUTHORIZED);
61                    $response->content("C'mon gimme a cert");
62                    $client->send_response($response);
63                    next;
64                }
65
66                # only handle POSTs to /RPC2
67                if ($request->method ne 'POST' || $request->url->path ne '/RPC2') {
68                    $client->send_error(HTTP_FORBIDDEN);
69                    next;
70                }
71
72                my $response;
73
74                eval {
75                    my $rpc_response = $srv->dispatch($request->content);
76                    my $content = $rpc_response->as_string;
77
78                    $response = HTTP::Response->new(HTTP_OK);
79                    $response->content($content);
80                };
81
82                # return an error on any kind of exception
83                if ($@) {
84                    $response = HTTP::Response->new(HTTP_BAD_REQUEST);
85                    $response->content('Are you even trying?');
86                }
87
88                $client->send_response($response);
89            }
90
91            exit;
92        }
93    }
94}
95
961;
Note: See TracBrowser for help on using the repository browser.