1 |
#!/usr/bin/perl |
2 |
## |
3 |
## POE::Component::RPCXML::Server -- XML-RPC Server Component |
4 |
## |
5 |
## $Id: Server.pm,v 1.3 2001/09/20 01:32:33 fletch Exp $ |
6 |
## |
7 |
package POE::Component::RPCXML::Server; |
8 |
|
9 |
use strict; |
10 |
|
11 |
use Carp qw( croak carp ); |
12 |
|
13 |
use POE qw( Kernel Session Wheel::ReadWrite Wheel::SocketFactory |
14 |
Filter::HTTPD Driver::SysRW ); |
15 |
|
16 |
use HTTP::Request (); |
17 |
use HTTP::Response (); |
18 |
|
19 |
use RPC::XML (); |
20 |
use RPC::XML::Parser (); |
21 |
|
22 |
use IO::Socket::INET qw( inet_ntoa ); |
23 |
|
24 |
$POE::Component::RPCXML::Server::VERSION = 0.02; |
25 |
|
26 |
my %default_args = ( |
27 |
Port => 7777, |
28 |
Debug => undef, |
29 |
Alias => 'rpcxml-server', |
30 |
); |
31 |
|
32 |
my $states = { |
33 |
_start => 'start', |
34 |
_stop => 'stop', |
35 |
event_signal => 'signal', |
36 |
_default => 'default', |
37 |
accept => 'accept', |
38 |
accept_error => 'accept_error', |
39 |
got_req => 'got_req', |
40 |
http_error => 'http_error', |
41 |
sent_rep => 'sent_rep', |
42 |
}; |
43 |
|
44 |
sub new { |
45 |
my $class = shift; |
46 |
$class = ref( $class ) || $class; |
47 |
my( %args ) = ( %default_args, @_ ); |
48 |
|
49 |
my $self = bless {}, $class; |
50 |
|
51 |
## Make sure that they've provided a DispatchEvent |
52 |
croak "Need DispatchEvent argument." |
53 |
unless exists $args{ DispatchEvent }; |
54 |
|
55 |
$self->{ _debug } = $args{ Debug }; |
56 |
$self->{ _alias } = $args{ Alias }; |
57 |
$self->{ _port } = $args{ Port }; |
58 |
$self->{ _dispatch } = $args{ DispatchEvent }; |
59 |
|
60 |
## Make our session. See $states defined up above . . . |
61 |
POE::Session->create( object_states => [ $self => $states, ], ); |
62 |
|
63 |
return $self; |
64 |
} |
65 |
|
66 |
## |
67 |
## start -- Startup state |
68 |
## |
69 |
sub start { |
70 |
my( $self, $kernel, $heap, $session, $sender ) = |
71 |
@_[ OBJECT, KERNEL, HEAP, SESSION, SENDER ]; |
72 |
|
73 |
## Pipe up if we're debugging |
74 |
print STDERR "## ", __PACKAGE__, "::start\r\n" if $self->{_debug}; |
75 |
|
76 |
# set signal handler |
77 |
POE::Kernel->sig('TERM', 'event_signal'); |
78 |
POE::Kernel->sig('QUIT', 'event_signal'); |
79 |
POE::Kernel->sig('INT', 'event_signal'); |
80 |
|
81 |
## Set the alias requested so we can be post'd to |
82 |
$kernel->alias_set( $self->{_alias} ); |
83 |
|
84 |
## Remember session that created us for posting DispatchEvent |
85 |
$self->{ _target } = $sender; |
86 |
|
87 |
## Create a wheel to listen for connections |
88 |
$heap->{wheel} = |
89 |
$self->_make_listen_wheel( |
90 |
'accept', # SuccessEvent |
91 |
'accept_error', # FailureEvent |
92 |
); |
93 |
return |
94 |
} |
95 |
|
96 |
## |
97 |
## stop -- Shutdown state |
98 |
## |
99 |
sub stop { |
100 |
my( $self, $kernel, $heap ) = @_[ OBJECT, KERNEL, HEAP ]; |
101 |
|
102 |
## Just pipe up if we're debugging |
103 |
print STDERR "## ", __PACKAGE__, "::stop\r\n" if $self->{_debug}; |
104 |
|
105 |
return |
106 |
} |
107 |
|
108 |
## |
109 |
## signal -- Handle any signals received |
110 |
## |
111 |
sub signal { |
112 |
my( $self, $heap, $signal ) = @_[ OBJECT, HEAP, ARG0 ]; |
113 |
|
114 |
## Just pipe up if we're debugging |
115 |
#print STDERR "## ", __PACKAGE__, "::signal $signal\n" if $self->{_debug}; |
116 |
print STDERR "## ", __PACKAGE__, "::signal $signal\n"; |
117 |
|
118 |
## shut things down on TERM, QUIT, or INT |
119 |
if( $signal =~ /^TERM|QUIT|INT/ ) { |
120 |
delete $heap->{wheel}; # toss our listening wheel reference |
121 |
|
122 |
## Check for child wheels |
123 |
my $live_wheels = scalar keys %{$heap->{wheels}}; |
124 |
if( $live_wheels ) { |
125 |
print STDERR "Exiting with $live_wheels clients still active\n" |
126 |
if $self->{_debug}; |
127 |
delete $heap->{wheels}; |
128 |
} |
129 |
} |
130 |
|
131 |
return |
132 |
} |
133 |
|
134 |
## |
135 |
## default -- Catch any unhandled events for debugging |
136 |
## |
137 |
sub default { |
138 |
my( $self, $heap, $event ) = @_[ OBJECT, HEAP, ARG0 ]; |
139 |
|
140 |
## Just pipe up if we're debugging |
141 |
print STDERR "## ", __PACKAGE__, "::default got $event\n" |
142 |
if $self->{_debug}; |
143 |
|
144 |
return |
145 |
} |
146 |
|
147 |
## |
148 |
## accept -- Posted when we've received a connection. Create new |
149 |
## ReadWrite wheel to service it |
150 |
## |
151 |
sub accept { |
152 |
my( $heap, $self, $socket, $host, $port, $id, $ssl ) |
153 |
= @_[ HEAP, OBJECT, ARG0..ARG4 ]; |
154 |
|
155 |
print STDERR "## ", __PACKAGE__, "::accept connection from ", |
156 |
inet_ntoa($host), ":$port\n" |
157 |
if $self->{_debug}; |
158 |
|
159 |
my $wheel = $self->_make_client_wheel( |
160 |
$socket, # handle |
161 |
'got_req', # InputEvent |
162 |
'http_error', # ErrorEvent |
163 |
'sent_rep', # FlushedEvent |
164 |
); |
165 |
|
166 |
$heap->{wheels}->{$wheel->ID} = $wheel; |
167 |
|
168 |
return |
169 |
} |
170 |
|
171 |
sub send_resp { |
172 |
my( $self, $wheel, $content ) = @_; |
173 |
|
174 |
my $resp = HTTP::Response->new( 200 ); |
175 |
|
176 |
$resp->push_header( 'Content-Type' => 'text/xml' ); |
177 |
$resp->push_header( 'Content-Length' => length $content ); |
178 |
$resp->push_header( 'RPC-Encoding' => 'XML-RPC' ); |
179 |
$resp->push_header( 'RPC-Server' => 'PoCo::RPCXML::Server/' |
180 |
. $POE::Component::RPCXML::VERSION ); |
181 |
|
182 |
$resp->content( $content ); |
183 |
|
184 |
$wheel->put( $resp ); |
185 |
|
186 |
} |
187 |
|
188 |
sub got_req { |
189 |
my( $heap, $self, $request, $wheel_id ) = @_[ HEAP, OBJECT, ARG0..ARG1 ]; |
190 |
|
191 |
my $wheel = $heap->{wheels}->{$wheel_id}; |
192 |
|
193 |
print STDERR "request:\n", $request->as_string, "\n" if $self->{_debug}; |
194 |
|
195 |
my $xmlreq = undef; |
196 |
eval { |
197 |
$xmlreq = RPC::XML::Parser->new()->parse( $request->content ); |
198 |
}; |
199 |
|
200 |
if( $@ ) { |
201 |
my $fault = RPC::XML::fault->new( 400 => "Bad Request: $@" ); |
202 |
my $xmlresp = RPC::XML::response->new( $fault ); |
203 |
$self->send_resp( $wheel, $xmlresp->as_string ); |
204 |
return |
205 |
} |
206 |
|
207 |
unless( ref $xmlreq ) { |
208 |
my $fault = RPC::XML::fault->new( 404 => 'No such method' ); |
209 |
my $xmlresp = RPC::XML::response->new( $fault ); |
210 |
$self->send_resp( $wheel, $xmlresp->as_string ); |
211 |
} else { |
212 |
$_[KERNEL]->post( $self->{_target}, $self->{_dispatch}, |
213 |
$xmlreq, $wheel ); |
214 |
|
215 |
#=pod |
216 |
# |
217 |
# my $xmlresp |
218 |
# = RPC::XML::response->new( RPC::XML::string->new( "OK " |
219 |
# . scalar localtime() |
220 |
# ) |
221 |
# ); |
222 |
# |
223 |
# $self->send_resp( $wheel, $xmlresp->as_string ); |
224 |
# |
225 |
#=cut |
226 |
} |
227 |
|
228 |
return |
229 |
} |
230 |
|
231 |
sub accept_error { |
232 |
my( $heap, $self, $operation, $errnum, $errstr, $wheel_id ) |
233 |
= @_[ HEAP, OBJECT, ARG0..ARG3 ]; |
234 |
|
235 |
warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n" |
236 |
if $self->{_debug}; |
237 |
|
238 |
if( $operation eq 'read' and $errnum == 0 ) { |
239 |
delete $heap->{wheel}; # shut down that wheel |
240 |
} |
241 |
|
242 |
return |
243 |
} |
244 |
|
245 |
sub http_error { |
246 |
my( $heap, $self, $operation, $errnum, $errstr, $wheel_id ) |
247 |
= @_[ HEAP, OBJECT, ARG0..ARG3 ]; |
248 |
|
249 |
warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n" |
250 |
if $self->{_debug}; |
251 |
|
252 |
if( $operation eq 'read' and $errnum == 0 ) { |
253 |
delete $heap->{wheels}->{$wheel_id}; # shut down that wheel |
254 |
} |
255 |
|
256 |
return |
257 |
} |
258 |
|
259 |
sub sent_rep { |
260 |
my( $heap, $self, $wheel_id ) = @_[ HEAP, OBJECT, ARG0 ]; |
261 |
|
262 |
delete $heap->{wheels}->{$wheel_id}; |
263 |
|
264 |
return |
265 |
} |
266 |
|
267 |
## |
268 |
## _make_{listen,client}_wheel -- make our wheels for us (in seperate |
269 |
## methods to facilitate subclassing) |
270 |
## |
271 |
sub _make_listen_wheel { |
272 |
my $self = shift; |
273 |
my( $success, $failure ) = @_; |
274 |
|
275 |
my $wheel = |
276 |
POE::Wheel::SocketFactory->new( |
277 |
BindPort => $self->{_port}, |
278 |
Reuse => 1, |
279 |
SuccessEvent => $success, |
280 |
FailureEvent => $failure, |
281 |
); |
282 |
|
283 |
return $wheel |
284 |
} |
285 |
|
286 |
sub _make_client_wheel { |
287 |
my $self = shift; |
288 |
my( $socket, $input, $error, $flushed ) = @_; |
289 |
|
290 |
## Create a new filter, driver, and ReadWrite wheel for the socket |
291 |
my $filter = POE::Filter::HTTPD->new( ); |
292 |
|
293 |
my $driver = POE::Driver::SysRW->new( ); |
294 |
|
295 |
my $wheel = POE::Wheel::ReadWrite->new( |
296 |
Handle => $socket, |
297 |
Filter => $filter, |
298 |
Driver => $driver, |
299 |
InputEvent => $input, |
300 |
ErrorEvent => $error, |
301 |
FlushedEvent => $flushed, |
302 |
); |
303 |
|
304 |
return $wheel |
305 |
} |
306 |
|
307 |
1; |
308 |
|
309 |
__END__ |
310 |
|
311 |
=pod |
312 |
|
313 |
=head1 NAME |
314 |
|
315 |
POE::Component::RPCXML::Server - POE RPCXML server |
316 |
|
317 |
=head1 SYNOPSIS |
318 |
|
319 |
use POE qw(Component::RPCXML::Server); |
320 |
|
321 |
=head1 DESCRIPTION |
322 |
|
323 |
This module implements a xmlrpc server in POE. |
324 |
|
325 |
Like many POE modules, Server does not create a new object when the |
326 |
C<new()> method is called - instead, a new POE session is started. |
327 |
|
328 |
=head2 CONSTRUCTOR |
329 |
|
330 |
To create a new RPCXML server session, make a call like this: |
331 |
|
332 |
POE::Component::RPCXML::Server->new( |
333 |
'Alias' => 'rpcxml-server', |
334 |
'Port' => $server_port, |
335 |
'DispatchEvent' => 'response', |
336 |
); |
337 |
|
338 |
Alias is the name of the alias to create for the session, Port is |
339 |
the port to run the server on, and DispatchEvent should be the |
340 |
state in the current session to call when a call is received. |
341 |
|
342 |
=head1 MESSAGES |
343 |
|
344 |
=head2 response |
345 |
|
346 |
This state receives a request object in C<ARG0>, and a wheel in C<ARG1>. |
347 |
It should examine the request object, construct a suitable C<RPC::XML::response> |
348 |
object, and send it back by calling the C<send_resp> method as |
349 |
follows: |
350 |
|
351 |
POE::Component::RPCXML::Server->send_resp($wheel, $response->as_string); |
352 |
|
353 |
=head1 AUTHOR |
354 |
|
355 |
Fletch E<lt>fletch@phydeaux.orgE<gt> |
356 |
|
357 |
=cut |