Component/RPCXML/Server.pm

#!/usr/bin/perl
##
## POE::Component::RPCXML::Server -- XML-RPC Server Component
##
## $Id: Server.pm,v 1.3 2001/09/20 01:32:33 fletch Exp $
##
package POE::Component::RPCXML::Server;

use strict;

use Carp qw( croak carp );

use POE qw( Kernel Session Wheel::ReadWrite Wheel::SocketFactory
            Filter::HTTPD Driver::SysRW );

use HTTP::Request ();
use HTTP::Response ();

use RPC::XML ();
use RPC::XML::Parser ();

use IO::Socket::INET qw( inet_ntoa );

$POE::Component::RPCXML::Server::VERSION = 0.02;

my %default_args = (
                    Port  => 7777,
                    Debug => undef,
                    Alias => 'rpcxml-server',
                   );

my $states = {
              _start       => 'start',
              _stop        => 'stop',
              event_signal      => 'signal',
              _default     => 'default',
              accept       => 'accept',
              accept_error => 'accept_error',
              got_req      => 'got_req',
              http_error   => 'http_error',
              sent_rep     => 'sent_rep',
             };

sub new {
  my $class = shift;
  $class = ref( $class ) || $class;
  my( %args ) = ( %default_args, @_ );

  my $self = bless {}, $class;

  ## Make sure that they've provided a DispatchEvent
  croak "Need DispatchEvent argument."
    unless exists $args{ DispatchEvent };

  $self->{ _debug    } = $args{ Debug };
  $self->{ _alias    } = $args{ Alias };
  $self->{ _port     } = $args{ Port };
  $self->{ _dispatch } = $args{ DispatchEvent };

  ## Make our session.  See $states defined up above . . .
  POE::Session->create( object_states => [ $self => $states, ], );
  
  return $self;
}

##
## start -- Startup state
##
sub start {
  my( $self, $kernel, $heap, $session, $sender ) =
    @_[ OBJECT, KERNEL, HEAP, SESSION, SENDER ];

  ## Pipe up if we're debugging
  print STDERR "## ", __PACKAGE__, "::start\r\n" if $self->{_debug};

  # set signal handler
  POE::Kernel->sig('TERM', 'event_signal');
  POE::Kernel->sig('QUIT', 'event_signal');
  POE::Kernel->sig('INT', 'event_signal');

  ## Set the alias requested so we can be post'd to
  $kernel->alias_set( $self->{_alias} );

  ## Remember session that created us for posting DispatchEvent
  $self->{ _target } = $sender;

  ## Create a wheel to listen for connections
  $heap->{wheel} =
    $self->_make_listen_wheel(
                              'accept', # SuccessEvent
                              'accept_error', # FailureEvent
                             );
  return
}

##
## stop -- Shutdown state
##
sub stop {
  my( $self, $kernel, $heap ) = @_[ OBJECT, KERNEL, HEAP ];

  ## Just pipe up if we're debugging
  print STDERR "## ", __PACKAGE__, "::stop\r\n" if $self->{_debug};

  return
}

##
## signal -- Handle any signals received
##
sub signal {
  my( $self, $heap, $signal ) = @_[ OBJECT, HEAP, ARG0 ];

  ## Just pipe up if we're debugging
  #print STDERR "## ", __PACKAGE__, "::signal $signal\n" if $self->{_debug};
  print STDERR "## ", __PACKAGE__, "::signal $signal\n";

  ## shut things down on TERM, QUIT, or INT
  if( $signal =~ /^TERM|QUIT|INT/ ) {
    delete $heap->{wheel};      # toss our listening wheel reference

    ## Check for child wheels
    my $live_wheels = scalar keys %{$heap->{wheels}};
    if( $live_wheels ) {
      print STDERR "Exiting with $live_wheels clients still active\n"
        if $self->{_debug};
      delete $heap->{wheels};
    }
  }

  return
}

##
## default -- Catch any unhandled events for debugging
##
sub default {
  my( $self, $heap, $event ) = @_[ OBJECT, HEAP, ARG0 ];

  ## Just pipe up if we're debugging
  print STDERR "## ", __PACKAGE__, "::default got $event\n"
    if $self->{_debug};

  return
}

##
## accept -- Posted when we've received a connection.  Create new
##           ReadWrite wheel to service it
##
sub accept {
  my( $heap, $self, $socket, $host, $port, $id, $ssl )
    = @_[ HEAP, OBJECT, ARG0..ARG4 ];

  print STDERR "## ", __PACKAGE__, "::accept connection from ",
               inet_ntoa($host), ":$port\n"
                 if $self->{_debug};

  my $wheel = $self->_make_client_wheel(
                                        $socket,      # handle
                                        'got_req',    # InputEvent
                                        'http_error', # ErrorEvent
                                        'sent_rep',   # FlushedEvent
                                       );

  $heap->{wheels}->{$wheel->ID} = $wheel;

  return
}

sub send_resp {
  my( $self, $wheel, $content ) = @_;

  my $resp = HTTP::Response->new( 200 );

  $resp->push_header( 'Content-Type'   => 'text/xml' );
  $resp->push_header( 'Content-Length' => length $content );
  $resp->push_header( 'RPC-Encoding'   => 'XML-RPC' );
  $resp->push_header( 'RPC-Server'     => 'PoCo::RPCXML::Server/'
                        . $POE::Component::RPCXML::VERSION );

  $resp->content( $content );

  $wheel->put( $resp );

}

sub got_req {
  my( $heap, $self, $request, $wheel_id ) = @_[ HEAP, OBJECT, ARG0..ARG1 ];

  my $wheel = $heap->{wheels}->{$wheel_id};

  print STDERR "request:\n", $request->as_string, "\n" if $self->{_debug};

  my $xmlreq = undef;
  eval {
    $xmlreq = RPC::XML::Parser->new()->parse( $request->content );
  };

  if( $@ ) {
    my $fault = RPC::XML::fault->new( 400 => "Bad Request: $@" );
    my $xmlresp = RPC::XML::response->new( $fault );
    $self->send_resp( $wheel, $xmlresp->as_string );
    return
  }

  unless( ref $xmlreq ) {
    my $fault = RPC::XML::fault->new( 404 => 'No such method' );
    my $xmlresp = RPC::XML::response->new( $fault );
    $self->send_resp( $wheel, $xmlresp->as_string );
  } else {
    $_[KERNEL]->post( $self->{_target}, $self->{_dispatch},
                      $xmlreq, $wheel );

#=pod
#
#    my $xmlresp
#      = RPC::XML::response->new( RPC::XML::string->new( "OK "
#                                                       . scalar localtime()
#                                                     )
#                              );
#
#    $self->send_resp( $wheel, $xmlresp->as_string );
#
#=cut
  }

  return
}

sub accept_error {
  my( $heap, $self, $operation, $errnum, $errstr, $wheel_id )
    = @_[ HEAP, OBJECT, ARG0..ARG3 ];

  warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n"
    if $self->{_debug};

  if( $operation eq 'read' and $errnum == 0 ) {
    delete $heap->{wheel}; # shut down that wheel
  }

  return
}

sub http_error {
  my( $heap, $self, $operation, $errnum, $errstr, $wheel_id )
    = @_[ HEAP, OBJECT, ARG0..ARG3 ];

  warn "Wheel $wheel_id generated $operation error $errnum: $errstr\n"
    if $self->{_debug};

  if( $operation eq 'read' and $errnum == 0 ) {
    delete $heap->{wheels}->{$wheel_id}; # shut down that wheel
  }

  return
}

sub sent_rep {
  my( $heap, $self, $wheel_id ) = @_[ HEAP, OBJECT, ARG0 ];

  delete $heap->{wheels}->{$wheel_id};

  return
}

##
## _make_{listen,client}_wheel -- make our wheels for us (in seperate
##                                methods to facilitate subclassing)
##
sub _make_listen_wheel {
  my $self = shift;
  my( $success, $failure ) = @_;

  my $wheel =
    POE::Wheel::SocketFactory->new(
                                   BindPort     => $self->{_port},
                                   Reuse        => 1,
                                   SuccessEvent => $success,
                                   FailureEvent => $failure,
                                  );

  return $wheel
}

sub _make_client_wheel {
  my $self = shift;
  my( $socket, $input, $error, $flushed ) = @_;

  ## Create a new filter, driver, and ReadWrite wheel for the socket
  my $filter = POE::Filter::HTTPD->new( );

  my $driver = POE::Driver::SysRW->new( );

  my $wheel = POE::Wheel::ReadWrite->new(
                                         Handle       => $socket,
                                         Filter       => $filter,
                                         Driver       => $driver,
                                         InputEvent   => $input,
                                         ErrorEvent   => $error,
                                         FlushedEvent => $flushed,
                                        );

  return $wheel
}

1;

__END__

=pod

=head1 NAME

POE::Component::RPCXML::Server - POE RPCXML server

=head1 SYNOPSIS

  use POE qw(Component::RPCXML::Server);

=head1 DESCRIPTION

This module implements a xmlrpc server in POE.

Like many POE modules, Server does not create a new object when the
C<new()> method is called - instead, a new POE session is started.

=head2 CONSTRUCTOR

To create a new RPCXML server session, make a call like this:

  POE::Component::RPCXML::Server->new(
                                      'Alias' => 'rpcxml-server',
                                      'Port'  => $server_port,
                                      'DispatchEvent' => 'response',
  );

Alias is the name of the alias to create for the session, Port is
the port to run the server on, and DispatchEvent should be the
state in the current session to call when a call is received.

=head1 MESSAGES

=head2 response

This state receives a request object in C<ARG0>, and a wheel in C<ARG1>.
It should examine the request object, construct a suitable C<RPC::XML::response>
object, and send it back by calling the C<send_resp> method as
follows:

  POE::Component::RPCXML::Server->send_resp($wheel, $response->as_string);

=head1 AUTHOR

Fletch E<lt>fletch@phydeaux.orgE<gt>

=cut
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
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26