1 |
jonen |
1.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 |