What sort of a heel would I be if I didn't provide the sample code? :-)
As mentioned, this is basically a quick hack of the POE Web Server With Forking example.
This sample program sets up a (rather useless) SOAP service with a method called 'sleep' which .... well you can guess.
Useless, but a good test of the success of the ability for this to service multiple requests at once, unlike SOAP::Transport::HTTP::Daemon.
#!/usr/bin/perl
use warnings;
use strict;
use SOAP::Transport::HTTP;
use lib 'lib';
sub DEBUG () { 0 } # Enable a lot of runtime information
+.
sub MAX_PROCESSES () { 10 } # Total number of server processes.
sub SERVER_PORT () { 8092 } # Server port to listen on.
sub TESTING_CHURN () { 0 } # Randomly shutdown children to test
+respawn.
use POE; # Base features.
use POE::Filter::HTTPD; # For serving HTTP content.
use POE::Wheel::ReadWrite; # For socket I/O.
use POE::Wheel::SocketFactory; # For serving socket connections.
# These are HTTP::Request headers that have methods.
my @method_headers =
qw( authorization authorization_basic
content content_encoding content_language content_length content_typ
+e
date expires from if_modified_since if_unmodified_since last_modifie
+d
method protocol proxy_authorization proxy_authorization_basic refere
+r
server title url user_agent www_authenticate
);
# These are HTTP::Request headers that do not have methods.
my @header_headers =
qw( username opaque stale algorithm realm uri qop auth nonce cnonce
nc response
);
# Spawn up to MAX_PROCESSES server processes, and then run them. Exit
# when they are done.
server_spawn(MAX_PROCESSES);
$poe_kernel->run();
exit 0;
### Spawn the main server. This will run as the parent process.
sub server_spawn {
my ($max_processes) = @_;
POE::Session->create
( inline_states =>
{ _start => \&server_start,
_stop => \&server_stop,
do_fork => \&server_do_fork,
got_error => \&server_got_error,
got_sig_int => \&server_got_sig_int,
got_sig_chld => \&server_got_sig_chld,
got_connection => \&server_got_connection,
_child => sub { 0 },
},
heap =>
{ max_processes => $max_processes,
},
);
}
### The main server session has started. Set up the server socket and
### bookkeeping information, then fork the initial child processes.
sub server_start {
my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
$heap->{server} = POE::Wheel::SocketFactory->new
( BindPort => SERVER_PORT,
SuccessEvent => "got_connection",
FailureEvent => "got_error",
Reuse => "yes",
);
$kernel->sig( CHLD => "got_sig_chld" );
$kernel->sig( INT => "got_sig_int" );
$heap->{children} = {};
$heap->{is_a_child} = 0;
warn "Server $$ has begun listening on port ", SERVER_PORT, "\n";
$kernel->yield("do_fork");
}
### The server session has shut down. If this process has any
### children, signal them to shutdown too.
sub server_stop {
my $heap = $_[HEAP];
DEBUG and warn "Server $$ stopped.\n";
if ( my @children = keys %{ $heap->{children} } ) {
DEBUG and warn "Server $$ is signaling children to stop.\n";
kill INT => @children;
}
}
### The server session has encountered an error. Shut it down.
sub server_got_error {
my ( $heap, $syscall, $errno, $error ) = @_[ HEAP, ARG0 .. ARG2 ];
warn( "Server $$ got $syscall error $errno: $error\n",
"Server $$ is shutting down.\n",
);
delete $heap->{server};
}
### The server has a need to fork off more children. Only honor that
### request form the parent, otherwise we would surely "forkbomb".
### Fork off as many child processes as we need.
sub server_do_fork {
my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
return if $heap->{is_a_child};
my $current_children = keys %{ $heap->{children} };
for ( $current_children + 2 .. $heap->{max_processes} ) {
DEBUG and warn "Server $$ is attempting to fork.\n";
my $pid = fork();
unless ( defined($pid) ) {
DEBUG and
warn( "Server $$ fork failed: $!\n",
"Server $$ will retry fork shortly.\n",
);
$kernel->delay( do_fork => 1 );
return;
}
# Parent. Add the child process to its list.
if ($pid) {
$heap->{children}->{$pid} = 1;
next;
}
# Child. Clear the child process list.
DEBUG and warn "Server $$ forked successfully.\n";
$heap->{is_a_child} = 1;
$heap->{children} = {};
return;
}
}
### The server session received SIGINT. Don't handle the signal,
### which in turn will trigger the process to exit gracefully.
sub server_got_sig_int {
DEBUG and warn "Server $$ received SIGINT.\n";
return 0;
}
### The server session received a SIGCHLD, indicating that some child
### server has gone away. Remove the child's process ID from our
### list, and trigger more fork() calls to spawn new children.
sub server_got_sig_chld {
my ( $kernel, $heap, $child_pid ) = @_[ KERNEL, HEAP, ARG1 ];
if ( delete $heap->{children}->{$child_pid} ) {
DEBUG and warn "Server $$ received SIGCHLD.\n";
$kernel->yield("do_fork");
}
return 0;
}
### The server session received a connection request. Spawn off a
### client handler session to parse the request and respond to it.
sub server_got_connection {
my ( $heap, $socket, $peer_addr, $peer_port ) = @_[ HEAP, ARG0, AR
+G1, ARG2 ];
DEBUG and warn "Server $$ received a connection.\n";
POE::Session->create
( inline_states =>
{ _start => \&client_start,
_stop => \&client_stop,
got_request => \&client_got_request,
got_flush => \&client_flushed_request,
got_error => \&client_got_error,
_parent => sub { 0 },
},
heap =>
{ socket => $socket,
peer_addr => $peer_addr,
peer_port => $peer_port,
},
);
delete $heap->{server}
if TESTING_CHURN and $heap->{is_a_child} and ( rand() < 0.1 );
}
### The client handler has started. Wrap its socket in a ReadWrite
### wheel to begin interacting with it.
sub client_start {
my $heap = $_[HEAP];
$heap->{client} = POE::Wheel::ReadWrite->new
( Handle => $heap->{socket},
Filter => POE::Filter::HTTPD->new(),
InputEvent => "got_request",
ErrorEvent => "got_error",
FlushedEvent => "got_flush",
);
DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " started.\n
+";
}
### The client handler has stopped. Log that fact.
sub client_stop {
DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " stopped.\n
+";
}
### The client handler has received a request. If it's an
### HTTP::Response object, it means some error has occurred while
### parsing the request. Send that back and return immediately.
### Otherwise parse and process the request, generating and sending an
### HTTP::Response object in response.
sub client_got_request {
my ( $heap, $request ) = @_[ HEAP, ARG0 ];
my $soap = SOAP::Transport::HTTP::Server
-> new
-> dispatch_to('SOAPPackage') ;
DEBUG and
warn "Client handler $$/", $_[SESSION]->ID, " is handling a requ
+est.\n";
if ( $request->isa("HTTP::Response") ) {
$heap->{client}->put($request);
return;
}
$soap->request($request);
$soap->handle;
my $response = $soap->response;
$heap->{client}->put($response);
}
### The client handler received an error. Stop the ReadWrite wheel,
### which also closes the socket.
sub client_got_error {
my ( $heap, $operation, $errnum, $errstr ) = @_[ HEAP, ARG0, ARG1,
+ ARG2 ];
DEBUG and
warn( "Client handler $$/", $_[SESSION]->ID,
" got $operation error $errnum: $errstr\n",
"Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
);
delete $heap->{client};
}
### The client handler has flushed its response to the socket. We're
### done with the client connection, so stop the ReadWrite wheel.
sub client_flushed_request {
my $heap = $_[HEAP];
DEBUG and
warn( "Client handler $$/", $_[SESSION]->ID,
" flushed its response.\n",
"Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
);
delete $heap->{client};
}
### We're done.
package SOAPPackage;
sub sleep {
my $class = shift;
my $sleep = shift;
if (! defined $sleep) {
die "no sleep time defined!";
}
if ($sleep !~ /^\d+$/) {
die "invalid sleep time '$sleep'";
}
warn "$$ is sleeping for $sleep";
sleep $sleep;
return "I slept for $sleep seconds";
}
Here's a quick and dirty client program to connect to it:
#!/usr/bin/perl
use strict;
use warnings;
use SOAP::Lite;
use Data::Dumper;
my $object;
my $method = shift;
$object = SOAP::Lite
-> uri('SOAPPackage')
-> proxy("http://localhost:8092/")
-> $method(@ARGV);
if ($object->fault) {
warn "FAULT " . $object->faultstring;
exit 1;
} else {
print Dumper($object->result);
exit 0;
}
| 