# Declare our package package POE::Component::Server::SimpleHTTP::PreFork; # Standard stuff to catch errors use strict qw(subs vars refs); # Make sure we can't mess up use warnings; # Enable warnings to catch errors # Initialize our version # $Revision: 1181 $ our $VERSION = '0.01'; # Import what we need from the POE namespace use POE; use base qw( POE::Component::Server::SimpleHTTP ); # Other miscellaneous modules we need use Carp qw( croak ); # HTTP-related modules use HTTP::Date qw( time2str ); # IPC modules use IPC::Shareable qw( :lock ); # Set some constants BEGIN { # Interval at which to check spares if ( !defined &CHECKSPARES_INTERVAL ) { eval "sub CHECKSPARES_INTERVAL () { 1 }"; } # Interval at which to retry preforking if ( !defined &PREFORK_INTERVAL ) { eval "sub PREFORK_INTERVAL () { 5 }"; } # If true, show the scoreboard every second if ( !defined &DEBUGSB ) { eval "sub DEBUGSB () { 0 }"; } } # Set things in motion! sub new { # Get the OOP's type my $type = shift; # Sanity checking if ( @_ & 1 ) { croak( 'POE::Component::Server::SimpleHTTP::PreFork->new needs even number of options' ); } # The options hash my %opt = @_; # Our own options my ( $ALIAS, $ADDRESS, $PORT, $HOSTNAME, $HEADERS, $HANDLERS, $SSLKEYCERT ); # options for pre-forking my ( $FORKHANDLERS, $STARTSERVERS, $MINSPARESERVERS, $MAXSPARESERVERS, $MAXCLIENTS, $MAXREQUESTPERCHILD ); # You could say I should do this: $Stuff = delete $opt{'Stuff'} # But, that kind of behavior is not defined, so I would not trust it... # Get the SSL array if ( exists $opt{'SSLKEYCERT'} and defined $opt{'SSLKEYCERT'} ) { # Test if it is an array if ( ref( $opt{'SSLKEYCERT'} ) eq 'ARRAY' and scalar( @{ $opt{'SSLKEYCERT'} } ) == 2 ) { $SSLKEYCERT = $opt{'SSLKEYCERT'}; delete $opt{'SSLKEYCERT'}; # Okay, pull in what is necessary eval { use POE::Component::SSLify qw( SSLify_Options SSLify_GetSocket Server_SSLify SSLify_GetCipher ); SSLify_Options(@$SSLKEYCERT); }; if ($@) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Unable to load PoCo::SSLify -> $@"; } # Force ourself to not use SSL $SSLKEYCERT = undef; } } else { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'The SSLKEYCERT option must be an array with exactly 2 elements in it!'; } } } else { $SSLKEYCERT = undef; } # Get the session alias if ( exists $opt{'ALIAS'} and defined $opt{'ALIAS'} and length( $opt{'ALIAS'} ) ) { $ALIAS = $opt{'ALIAS'}; delete $opt{'ALIAS'}; } else { # Debugging info... if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Using default ALIAS = SimpleHTTP'; } # Set the default $ALIAS = 'SimpleHTTP'; # Get rid of any lingering ALIAS if ( exists $opt{'ALIAS'} ) { delete $opt{'ALIAS'}; } } # Get the PORT if ( exists $opt{'PORT'} and defined $opt{'PORT'} and length( $opt{'PORT'} ) ) { $PORT = $opt{'PORT'}; delete $opt{'PORT'}; } else { croak( 'PORT is required to create a new POE::Component::Server::SimpleHTTP instance!' ); } # Get the ADDRESS if ( exists $opt{'ADDRESS'} and defined $opt{'ADDRESS'} and length( $opt{'ADDRESS'} ) ) { $ADDRESS = $opt{'ADDRESS'}; delete $opt{'ADDRESS'}; } else { croak( 'ADDRESS is required to create a new POE::Component::Server::SimpleHTTP instance!' ); } # Get the HOSTNAME if ( exists $opt{'HOSTNAME'} and defined $opt{'HOSTNAME'} and length( $opt{'HOSTNAME'} ) ) { $HOSTNAME = $opt{'HOSTNAME'}; delete $opt{'HOSTNAME'}; } else { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Using Sys::Hostname for HOSTNAME'; } # Figure out the hostname require Sys::Hostname; $HOSTNAME = Sys::Hostname::hostname(); # Get rid of any lingering HOSTNAME if ( exists $opt{'HOSTNAME'} ) { delete $opt{'HOSTNAME'}; } } # Get the HEADERS if ( exists $opt{'HEADERS'} and defined $opt{'HEADERS'} ) { # Make sure it is ref to hash if ( ref $opt{'HEADERS'} and ref( $opt{'HEADERS'} ) eq 'HASH' ) { $HEADERS = $opt{'HEADERS'}; delete $opt{'HEADERS'}; } else { croak('HEADERS must be a reference to a HASH!'); } } else { # Set to none $HEADERS = {}; # Get rid of any lingering HEADERS if ( exists $opt{'HEADERS'} ) { delete $opt{'HEADERS'}; } } # Get the HANDLERS if ( exists $opt{'HANDLERS'} and defined $opt{'HANDLERS'} ) { # Make sure it is ref to array if ( ref $opt{'HANDLERS'} and ref( $opt{'HANDLERS'} ) eq 'ARRAY' ) { $HANDLERS = $opt{'HANDLERS'}; delete $opt{'HANDLERS'}; } else { croak('HANDLERS must be a reference to an ARRAY!'); } } else { croak( 'HANDLERS is required to create a new POE::Component::Server::SimpleHTTP instance!' ); } # Get the FORKHANDLERS if ( exists $opt{'FORKHANDLERS'} and defined $opt{'FORKHANDLERS'} ) { # Make sure it is ref to a hash if ( ref $opt{'FORKHANDLERS'} and ref( $opt{'FORKHANDLERS'} ) eq 'HASH' ) { $FORKHANDLERS = $opt{'FORKHANDLERS'}; delete $opt{'FORKHANDLERS'}; } else { croak('FORKHANDLERS must be a reference to a HASH!'); } } else { $FORKHANDLERS = {}; # Get rid of any lingering FORKHANDLERS if ( exists $opt{'FORKHANDLERS'} ) { delete $opt{'FORKHANDLERS'}; } } # Get the MINSPARESERVERS if ( exists $opt{'MINSPARESERVERS'} and defined $opt{'MINSPARESERVERS'} ) { $MINSPARESERVERS = int $opt{'MINSPARESERVERS'}; delete $opt{'MINSPARESERVERS'}; if ( $MINSPARESERVERS <= 0 ) { croak('MINSPARESERVERS must be greater than 0!'); } } else { $MINSPARESERVERS = 5; # Get rid of any lingering MINSPARESERVERS if ( exists $opt{'MINSPARESERVERS'} ) { delete $opt{'MINSPARESERVERS'}; } } # Get the MAXSPARESERVERS if ( exists $opt{'MAXSPARESERVERS'} and defined $opt{'MAXSPARESERVERS'} ) { $MAXSPARESERVERS = int $opt{'MAXSPARESERVERS'}; delete $opt{'MAXSPARESERVERS'}; } else { $MAXSPARESERVERS = 10; # Get rid of any lingering MAXSPARESERVERS if ( exists $opt{'MAXSPARESERVERS'} ) { delete $opt{'MAXSPARESERVERS'}; } } # Adjust and make sure MAXSPARESERVERS makes sense if ( $MAXSPARESERVERS <= $MINSPARESERVERS ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'MAXSPARESERVERS is less than or equal to MINSPARESERVERS. Resetting.'; } $MAXSPARESERVERS = $MINSPARESERVERS + 1; } # Get the MAXCLIENTS if ( exists $opt{'MAXCLIENTS'} and defined $opt{'MAXCLIENTS'} ) { $MAXCLIENTS = int $opt{'MAXCLIENTS'}; delete $opt{'MAXCLIENTS'}; } else { $MAXCLIENTS = 256; # Get rid of any lingering MAXCLIENTS if ( exists $opt{'MAXCLIENTS'} ) { delete $opt{'MAXCLIENTS'}; } } # Get the MAXREQUESTPERCHILD if ( exists $opt{'MAXREQUESTPERCHILD'} and defined $opt{'MAXREQUESTPERCHILD'} ) { $MAXREQUESTPERCHILD = int $opt{'MAXREQUESTPERCHILD'}; delete $opt{'MAXREQUESTPERCHILD'}; if ( $MAXREQUESTPERCHILD <= 0 ) { croak('MAXREQUESTPERCHILD must be greater than 0!'); } } # Get the STARTSERVERS if ( exists $opt{'STARTSERVERS'} and defined $opt{'STARTSERVERS'} ) { $STARTSERVERS = int $opt{'STARTSERVERS'}; delete $opt{'STARTSERVERS'}; if ( $STARTSERVERS <= 0 ) { croak('STARTSERVERS must be greater than or equal to 0!'); } } else { $STARTSERVERS = 10; # Get rid of any lingering STARTSERVERS if ( exists $opt{'STARTSERVERS'} ) { delete $opt{'STARTSERVERS'}; } } # Adjust and make sure STARTSERVERS makes sense if ( $STARTSERVERS < $MINSPARESERVERS ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'STARTSERVERS is less than MINSPARESERVERS. Resetting.'; } $STARTSERVERS = $MINSPARESERVERS; } # Anything left over is unrecognized if (POE::Component::Server::SimpleHTTP::DEBUG) { if ( keys %opt > 0 ) { croak( 'Unrecognized options were present in POE::Component::Server::SimpleHTTP::PreFork->new -> ' . join( ', ', keys %opt ) ); } } # Create a new session for ourself POE::Session->create( # Our subroutines 'inline_states' => { # Maintenance events '_start' => \&StartServer, '_stop' => \&POE::Component::Server::SimpleHTTP::FindRequestLeaks, '_child' => sub { }, # Pre-forking events 'ISCHILD' => \&IsChild, 'GETFORKHANDLERS' => \&GetForkHandlers, 'SETFORKHANDLERS' => \&SetForkHandlers, # Internal pre-forking events 'SigCHLD' => \&SigCHLD, 'SigTERM' => \&SigTERM, 'PreFork' => \&PreFork, 'KillChildren' => \&KillChildren, 'CheckSpares' => \&CheckSpares, 'UpdateScoreboard' => \&UpdateScoreboard, 'AddScoreboard' => \&AddScoreboard, 'ShowScoreboard' => \&ShowScoreboard, # HANDLER stuff 'GETHANDLERS' => \&POE::Component::Server::SimpleHTTP::GetHandlers, 'SETHANDLERS' => \&SetHandlers, # SocketFactory events 'SHUTDOWN' => \&StopServer, 'STOPLISTEN' => \&StopListen, 'STARTLISTEN' => \&StartListen, 'SetupListener' => \&SetupListener, 'ListenerError' => \&POE::Component::Server::SimpleHTTP::ListenerError, # Wheel::ReadWrite stuff 'Got_Connection' => \&Got_Connection, 'Got_Input' => \&Got_Input, 'Got_Flush' => \&Got_Flush, 'Got_Error' => \&Got_Error, # Send output to connection! 'DONE' => \&POE::Component::Server::SimpleHTTP::Request_Output, # Stream output to connection! 'STREAM' => \&POE::Component::Server::SimpleHTTP::Stream_Output, # Kill the connection! 'CLOSE' => \&Request_Close, }, # Set up the heap for ourself 'heap' => { 'ALIAS' => $ALIAS, 'ADDRESS' => $ADDRESS, 'PORT' => $PORT, 'HEADERS' => $HEADERS, 'HOSTNAME' => $HOSTNAME, 'HANDLERS' => $HANDLERS, 'REQUESTS' => {}, 'RETRIES' => 0, 'SSLKEYCERT' => $SSLKEYCERT, 'MINSPARESERVERS' => $MINSPARESERVERS, 'MAXSPARESERVERS' => $MAXSPARESERVERS, 'MAXCLIENTS' => $MAXCLIENTS, 'STARTSERVERS' => $STARTSERVERS, 'MAXREQUESTPERCHILD' => $MAXREQUESTPERCHILD, 'ISCHILD' => 0, 'FORKHANDLERS' => $FORKHANDLERS, 'SCOREBOARD' => undef }, ) or die 'Unable to create a new session!'; # Return success return 1; } # Starts the server! sub StartServer { # Settup our signal handlers $_[KERNEL]->sig( TERM => 'SigTERM' ); $_[KERNEL]->sig( CHLD => 'SigCHLD' ); # Call the super class method. return POE::Component::Server::SimpleHTTP::StartServer(@_); } # Stops the server! sub StopServer { my $children; # Shutdown the SocketFactory wheel if ( exists $_[HEAP]->{'SOCKETFACTORY'} ) { delete $_[HEAP]->{'SOCKETFACTORY'}; } # Debug stuff if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Stopped listening for new connections!'; } # Are we gracefully shutting down or not? if ( defined $_[ARG0] and $_[ARG0] eq 'GRACEFUL' ) { # Attempt to gracefully kill the children. $children = $_[KERNEL]->call( $_[SESSION], 'KillChildren', 'TERM' ); # Check for number of requests, and children. if ( ( keys( %{ $_[HEAP]->{'REQUESTS'} } ) == 0 ) && ( $children == 0 ) ) { # Alright, shutdown anyway # Delete our alias $_[KERNEL]->alias_remove( $_[HEAP]->{'ALIAS'} ); # Destroy all memory segments created by this process. IPC::Shareable->clean_up; $_[HEAP]->{'SCOREBOARD'} = undef; # Debug stuff if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Stopped SimpleHTTP gracefully, no requests left'; } } # All done! return 1; } # CheckSpares need to know that we're shutting down $_[HEAP]->{'SCOREBOARD'}->{'shutdown'} = 1; # Forcefully kill all the children. $_[KERNEL]->call( $_[SESSION], 'KillChildren', 'KILL' ); # Forcibly close all sockets that are open foreach my $conn ( keys %{ $_[HEAP]->{'REQUESTS'} } ) { # Can't call method "shutdown_input" on an undefined value at # /usr/lib/perl5/site_perl/5.8.2/POE/Component/Server/SimpleHTTP.pm line 323. if ( defined $_[HEAP]->{'REQUESTS'}->{$conn}->[0] and defined $_[HEAP]->{'REQUESTS'}->{$conn}->[0] ->[POE::Wheel::ReadWrite::HANDLE_INPUT] ) { $_[HEAP]->{'REQUESTS'}->{$conn}->[0]->shutdown_input; $_[HEAP]->{'REQUESTS'}->{$conn}->[0]->shutdown_output; } # Delete this request delete $_[HEAP]->{'REQUESTS'}->{$conn}; } # Remove any shared memory segments. IPC::Shareable->clean_up; $_[HEAP]->{'SCOREBOARD'} = undef; # Delete our alias $_[KERNEL]->alias_remove( $_[HEAP]->{'ALIAS'} ); # Debug stuff if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Successfully stopped SimpleHTTP'; } # Return success return 1; } # Kill all our children, and return the number we sent signals too. sub KillChildren { my ( $heap, $sig ) = @_[ HEAP, ARG0 ]; my ( $children, $scoreboard, $mem ) = 0; # By default, kill them nicely. $sig = 'TERM' unless defined $sig; # Make sure we are the parent AND preforked. if ( $heap->{'ISCHILD'} == 0 ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Killing children from $$ with signal $sig."; } $scoreboard = $heap->{'SCOREBOARD'}; $mem = tied %$scoreboard; if ( not defined $mem ) { # There was an error, but there's nothing we can do, # so just exit. warn "Parent's SCOREBOARD is not tied!"; $children = 0; } else { # Get a count of the number of children, and start killing them $mem->shlock(LOCK_SH); # The children haven't already received a signal, so send them one. foreach my $pid ( keys %$scoreboard ) { if ( ( $pid ne 'actives' ) && ( $pid ne 'spares' ) ) { ++$children; kill $sig, $pid; } } $mem->shlock(LOCK_UN); # Check to make sure it is sane. if ( $children < 0 ) { warn "The child count is negative: $children."; $children = 0; } } } # $_[KERNEL]->delay_set('CheckSpares'); return $children; } # Sets up the SocketFactory wheel :) sub SetupListener { # Debug stuff if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Creating SocketFactory wheel now'; } # Only try to re-establish the listener if we are the parent if ( $_[HEAP]->{'ISCHILD'} ) { warn 'Inside the child. Aborting attempt to reestablish the listener.'; return 0; } # Check if we should set up the wheel if ( $_[HEAP]->{'RETRIES'} == POE::Component::Server::SimpleHTTP::MAX_RETRIES ) { die 'POE::Component::Server::SimpleHTTP::PreFork tried ' . POE::Component::Server::SimpleHTTP::MAX_RETRIES . ' times to create a Wheel and is giving up...'; } else { # Increment the retry count if we did not get 'NOINC' as an argument if ( !defined $_[ARG0] ) { # Increment the retries count $_[HEAP]->{'RETRIES'}++; } # Create our own SocketFactory Wheel :) $_[HEAP]->{'SOCKETFACTORY'} = POE::Wheel::SocketFactory->new( 'BindPort' => $_[HEAP]->{'PORT'}, 'BindAddress' => $_[HEAP]->{'ADDRESS'}, 'Reuse' => 'yes', 'SuccessEvent' => 'Got_Connection', 'FailureEvent' => 'ListenerError', ); # Pre-fork if that is what was requested if ( $_[HEAP]->{'STARTSERVERS'} ) { # We don't want to accept socket connections in the parent process $_[HEAP]->{'SOCKETFACTORY'}->pause_accept(); # Wait a bit and then do the actual forking $_[KERNEL]->yield( 'PreFork', $_[HEAP]->{'SOCKETFACTORY'} ); } } # Success! return 1; } # PreFork the initial instances. sub PreFork { # ARG0 = SocketFactory my ( $kernel, $heap, $sf ) = @_[ KERNEL, HEAP, ARG0 ]; my ( $scoreboard, $mem ); if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Trying to prefork.'; } # Only the parent is allowed to fork if ( $heap->{'ISCHILD'} ) { warn "Cannot pre-fork from child $$."; return 0; } # Make that the current SF is the same as the one we were called for. # If not, then that means and error occured sometime inbetween. if ( ( not defined $heap->{'SOCKETFACTORY'} ) || ( $sf != $heap->{'SOCKETFACTORY'} ) ) { warn 'Aborting pre-fork because the SocketFactory is not the same.'; return 0; } # Initialize the scoreboard the first time around. if ( not defined $heap->{'SCOREBOARD'} ) { my %temp; # In order to keep a pool of spare children we need to know how many spares there are. $mem = tie %temp, 'IPC::Shareable', 'scbd', { 'create' => 1, 'mode' => 0600 }; $scoreboard = \%temp; } else { # We already have a scoreboard from a previous listen attempt. $scoreboard = $heap->{'SCOREBOARD'}; $mem = tied %$scoreboard; } if ( not defined $mem ) { warn 'Cannot tie to the shared memory segment. Will try again in 5 seconds.'; $kernel->delay_set( 'PreFork', PREFORK_INTERVAL, $sf ); return 0; } else { # Clear the variable and store it for later use. %$scoreboard = ( 'spares' => 0, 'actives' => 0 ); $heap->{'SCOREBOARD'} = $scoreboard; } for ( 1 .. $heap->{'STARTSERVERS'} ) { my $pid = fork(); if ( not defined $pid ) { # Make sure this fork succeeded. warn "Server $$ fork failed: $!"; next; } elsif ($pid) { # We are the parent. next; } else { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Forked child $$."; } # We are the child. Do something "childish". $heap->{'ISCHILD'} = 1; $kernel->call( $_[SESSION], 'AddScoreboard' ); # Notify the other forked sessions that we have forked. foreach my $sess ( keys( %{ $heap->{'FORKHANDLERS'} } ) ) { $_[KERNEL]->call( $sess, $heap->{'FORKHANDLERS'}->{$sess} ); } # Get to work! $sf->resume_accept(); return 1; } } # Pre-forking is done and our children are happily away! # We are the parent, so start monitoring the spare pool. $kernel->delay_set( 'CheckSpares', CHECKSPARES_INTERVAL ); # Let the developer see the scoreboard if they want. if (DEBUGSB) { $kernel->delay_set( 'ShowScoreboard', 1 ); } } # True if this is a child. sub IsChild { return $_[HEAP]->{'ISCHILD'}; } # Check to see if we need a new spare. sub CheckSpares { my ( $kernel, $heap ) = @_[ KERNEL, HEAP ]; my ( $scoreboard, $mem ); # Make sure that we are not a child. if ( $heap->{'ISCHILD'} ) { warn "Child $$ trying to check the spares!"; return 0; } # Make sure there is still a socket factory. If not, then this server # is shutting down. if ( not defined $heap->{'SOCKETFACTORY'} ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Ending CheckSpares on the parent.'; } return 1; } # Retrieve the shared memory variable. $scoreboard = $heap->{'SCOREBOARD'}; # in the test for maxrequestperchild the only # way to have CheckSpare aware that we're shutting down # is using this shared variable if ( defined $scoreboard->{'shutdown'} ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn 'Shutdown in progress, checkspare is useless'; } return 1; } $mem = tied %$scoreboard if defined $scoreboard; if ( not defined $mem ) { warn 'SCOREBOARD is not tied! Aborting.'; return 0; } # Check to see if we need another spare, and if so make sure we don't # already have more than enough clients. $mem->shlock(LOCK_SH); if ( ( $scoreboard->{'spares'} < $heap->{'MINSPARESERVERS'} ) && ( ( keys(%$scoreboard) - 2 ) < $heap->{'MAXCLIENTS'} ) ) { $mem->shlock(LOCK_UN); my $pid = fork(); if ( not defined $pid ) { warn 'fork failed while creating a new spare.'; } elsif ($pid) { # We are the parent. } else { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Created spare child $$."; } # We are the child. Do something "childish". $heap->{'ISCHILD'} = 1; $kernel->call( $_[SESSION], 'AddScoreboard' ); # Notify the other forked sessions that we have forked. foreach my $sess ( keys( %{ $heap->{'FORKHANDLERS'} } ) ) { $_[KERNEL]->call( $sess, $heap->{'FORKHANDLERS'}->{$sess} ); } # Start accepting connections! $heap->{'SOCKETFACTORY'}->resume_accept(); } } else { # No new spares were needed. $mem->shlock(LOCK_UN); } # If we are the parent, then reschedule another spare check. if ( $heap->{'ISCHILD'} == 0 ) { $kernel->delay_set( 'CheckSpares', CHECKSPARES_INTERVAL ); } } # Debug routine so that we can watch what is happening on the scoreboard. sub ShowScoreboard { my ($heap) = $_[HEAP]; my ( $scoreboard, $mem, $hcount, $pid ); # Check to make sure we are not a child. if ( $heap->{'ISCHILD'} ) { return 0; } # Check to make sure the scoreboard is still up. $scoreboard = $heap->{'SCOREBOARD'}; if ( not defined $scoreboard ) { return 0; } # Retrieve the underlying class. $mem = tied %$scoreboard; if ( not defined $mem ) { warn 'SCOREBOARD is not tied! Aborting.'; return 0; } # Lock the scoreboard and print out the entries. $mem->shlock(LOCK_SH); $hcount = 0; print STDERR "[$$] actives = ", $scoreboard->{'actives'}, "\tspares = ", $scoreboard->{'spares'}, "\n"; foreach $pid ( keys %$scoreboard ) { next if ( $pid eq 'actives' ) || ( $pid eq 'spares' ); print STDERR $pid, " = ", $scoreboard->{$pid}; if ( ++$hcount % 5 == 0 ) { print STDERR "\n"; } else { print STDERR "\t"; } } print STDERR "\n\n"; $mem->shlock(LOCK_UN); # If the socketfactory still exists then we should continue looping. if ( exists $heap->{'SOCKETFACTORY'} ) { $_[KERNEL]->delay_set( 'ShowScoreboard', 1 ); } } # A child died :( sub SigCHLD { my ( $heap, $pid ) = @_[ HEAP, ARG1 ]; my ( $scoreboard, $mem, $children ); # Check to see if we are in preforked mode and the parent. if ( $heap->{'ISCHILD'} == 0 ) { # Retrieve our scoreboard. $scoreboard = $heap->{'SCOREBOARD'}; $mem = tied %$scoreboard if defined $scoreboard; if ( not defined $mem ) { warn 'Cannot get the IPC::Shareable object for the SCOREBOARD!'; return; } $mem->shlock(LOCK_EX); # Cleanup children here (they should never do it themselves). if ( exists $scoreboard->{$pid} ) { if ( $scoreboard->{$pid} eq 'S' ) { --$scoreboard->{'spares'}; } elsif ( $scoreboard->{$pid} eq 'A' ) { --$scoreboard->{'actives'}; } delete $scoreboard->{$pid}; } # Get the number of children. $children = keys(%$scoreboard) - 2; $mem->shlock(LOCK_UN); # If the children are dying and the SOCKETFACTORY no longer exists, then # we are probably in a graceful shutdown. if ( ( $children <= 0 ) && ( not exists $heap->{'SOCKETFACTORY'} ) ) { $_[KERNEL]->yield( 'SHUTDOWN', 'GRACEFUL' ); } } } # Someone is asking us to quit... sub SigTERM { my ($sig) = $_[ARG0]; if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Caught signal ", $sig, " inside $$. Initiating graceful shutdown."; } # Shutdown gracefully, and tell POE we handled the signal. $_[KERNEL]->yield( 'SHUTDOWN', 'GRACEFUL' ); $_[KERNEL]->sig_handled(); } # Add the scoreboard entry for this child. sub AddScoreboard { my ($heap) = $_[HEAP]; my ( $scoreboard, $mem ); # Check to see if we are preforked. if ( $heap->{'ISCHILD'} ) { $scoreboard = $heap->{'SCOREBOARD'}; $mem = tied %$scoreboard if defined $scoreboard; if ( not defined $mem ) { # Don't do anyting if we can't lock stuff. warn "SCOREBOARD is not tied to IPC::Shareable in child $$!"; } else { # Lock the scoreboard and record ourself properly. $mem->shlock(LOCK_EX); if ( not exists $scoreboard->{$$} ) { $scoreboard->{$$} = 'S'; ++$scoreboard->{'spares'}; } $mem->shlock(LOCK_UN); } } return 1; } # Set the scoreboard entry for this child. sub UpdateScoreboard { my ($heap) = $_[HEAP]; my ( $scoreboard, $mem ); # Check to see if we are preforked. if ( $heap->{'ISCHILD'} ) { $scoreboard = $heap->{'SCOREBOARD'}; $mem = tied %$scoreboard if defined $scoreboard; if ( not defined $mem ) { # Don't do anyting if we can't lock stuff. warn "SCOREBOARD is not tied to IPC::Shareable in child $$!"; } else { # Lock the scoreboard and record ourself properly. $mem->shlock(LOCK_EX); if ( ( keys( %{ $heap->{'REQUESTS'} } ) == 0 ) && ( $scoreboard->{$$} eq 'A' ) ) { $scoreboard->{$$} = 'S'; ++$scoreboard->{'spares'}; --$scoreboard->{'actives'}; # If we have too many spares then ask this one to shutdown. if ( $scoreboard->{'spares'} > $heap->{'MAXSPARESERVERS'} ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Shutting down $$ because of too many spares."; } $_[KERNEL]->yield( 'SHUTDOWN', 'GRACEFUL' ); } } elsif ( ( keys( %{ $heap->{'REQUESTS'} } ) != 0 ) && ( $scoreboard->{$$} eq 'S' ) ) { $scoreboard->{$$} = 'A'; --$scoreboard->{'spares'}; ++$scoreboard->{'actives'}; } $mem->shlock(LOCK_UN); } } return 1; } # Stops listening on the socket sub StopListen { if ( $_[HEAP]->{'ISCHILD'} ) { # If we are the child then we shouldn't really stop listening. # Instead, pause accepting on our SocketFactory. if ( ( not exists $_[HEAP]->{'SOCKETFACTORY'} ) || ( not defined $_[HEAP]->{'SOCKETFACTORY'} ) ) { warn "Cannot StopListen on a non-existant SOCKETFACTORY in child $$"; return 0; } else { # Pause accepting. $_[HEAP]->{'SOCKETFACTORY'}->pause_accept(); return 1; } } else { # We are in the parent, so truly stop listening. # Kill the children because they are still listenning. $_[KERNEL]->call( $_[SESSION], 'KillChildren', 'TERM' ); # Call the super class method. return POE::Component::Server::SimpleHTTP::StopListen(@_); } } sub StartListen { if ( $_[HEAP]->{'ISCHILD'} ) { # If we are the child then we can't really create a new SOCKETFACTORY. # Instead, we can resume accepting on our current SOCKETFACTORY. if ( ( not exists $_[HEAP]->{'SOCKETFACTORY'} ) || ( not defined $_[HEAP]->{'SOCKETFACTORY'} ) ) { warn "Cannot StartListen on a non-existant SOCKETFACTORY in child $$"; return 0; } else { # Resume accepting. $_[HEAP]->{'SOCKETFACTORY'}->resume_accept(); return 1; } } else { # We are the parent. Truly start listening again. return POE::Component::Server::SimpleHTTP::StartListen(@_); } } # Sets the HANDLERS sub SetHandlers { # Setting handlers in a child makes little sense, so abort if this is the case if ( $_[HEAP]->{'ISCHILD'} ) { warn "Child $$ tried to set the handlers for SimpleHTTP."; return 0; } # Call the super class method. return POE::Component::Server::SimpleHTTP::SetHandlers(@_); } # Sets the FORKHANDLERS sub SetForkHandlers { # ARG0 = ref to handlers hash my $handlers = $_[ARG0]; # Setting handlers in a child makes little sense, so abort if this is the case. if ( $_[HEAP]->{'ISCHILD'} ) { warn "Child $$ tried to set the handlers for SimpleHTTP."; return 0; } # Validate it... if ( ( not defined $handlers ) || ( ref($handlers) ne 'HASH' ) ) { warn "FORKHANDLERS is not in the proper format."; return 0; } # If we got here, passed tests! $_[HEAP]->{'FORKHANDLERS'} = $handlers; # All done! return 1; } # Gets the FORKHANDLERS sub GetForkHandlers { # ARG0 = session, ARG1 = event my ( $session, $event ) = @_[ ARG0, ARG1 ]; # Validation if ( !defined $session or !defined $event ) { return undef; } # Make a deep copy of the handlers require Storable; my $handlers = Storable::dclone( $_[HEAP]->{'FORKHANDLERS'} ); # All done! $_[KERNEL]->post( $session, $event, $handlers ); # All done! return 1; } # The actual manager of connections sub Got_Connection { # ARG0 = Socket, ARG1 = Remote Address, ARG2 = Remote Port my ($socket) = $_[ARG0]; # Should we SSLify it? if ( defined $_[HEAP]->{'SSLKEYCERT'} ) { # SSLify it! eval { $socket = Server_SSLify($socket) }; if ($@) { warn "Unable to turn on SSL for connection from " . Socket::inet_ntoa( $_[ARG1] ) . " -> $@"; close $socket; return 1; } } # Set up the Wheel to read from the socket my $wheel = POE::Wheel::ReadWrite->new( 'Handle' => $socket, 'Driver' => POE::Driver::SysRW->new(), 'Filter' => POE::Filter::HTTPD->new(), 'InputEvent' => 'Got_Input', 'FlushedEvent' => 'Got_Flush', 'ErrorEvent' => 'Got_Error', ); # Save this wheel! # 0 = wheel, 1 = Output done?, 2 = SimpleHTTP::Response object $_[HEAP]->{'REQUESTS'}->{ $wheel->ID } = [ $wheel, 0, undef ]; # Update the scoreboard. $_[KERNEL]->call( $_[SESSION], 'UpdateScoreboard' ); # Debug stuff if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Got_Connection completed creation of ReadWrite wheel ( " . $wheel->ID . " )"; } # Success! return 1; } # Finally got input, set some stuff and send away! sub Got_Input { # ARG0 = HTTP::Request object, ARG1 = Wheel ID my ( $request, $id ) = @_[ ARG0, ARG1 ]; # Call the super class method. my $rv = POE::Component::Server::SimpleHTTP::Got_Input(@_); # If the connection died/failed for some reason then the request is deleted. # In this case, we have to update the scoreboard. if ( not exists $_[HEAP]->{'REQUESTS'}->{$id} ) { $_[KERNEL]->call( $_[SESSION], 'UpdateScoreboard' ); } return $rv; } # Finished with a request! sub Got_Flush { # ARG0 = wheel ID my ($id) = $_[ARG0]; # Call the super class method. my $rv = POE::Component::Server::SimpleHTTP::Got_Flush(@_); # Deal with maxrequestperchild if ( $_[HEAP]->{'ISCHILD'} && defined $_[HEAP]->{'MAXREQUESTPERCHILD'} ) { $_[HEAP]->{'REQUESTCOUNT'}++; if ( $_[HEAP]->{'REQUESTCOUNT'} >= $_[HEAP]->{'MAXREQUESTPERCHILD'} ) { if (POE::Component::Server::SimpleHTTP::DEBUG) { warn "Shutting down $$ because it reached MAXREQUESTPERCHILD."; } $_[KERNEL]->yield( 'SHUTDOWN', 'GRACEFUL' ); return 1; } } # If the connection died/failed for some reason then the request is deleted. # In this case, we have to update the scoreboard. if ( not exists $_[HEAP]->{'REQUESTS'}->{$id} ) { $_[KERNEL]->call( $_[SESSION], 'UpdateScoreboard' ); } return $rv; } # Got some sort of error from ReadWrite sub Got_Error { # Call the super class method. my $rv = POE::Component::Server::SimpleHTTP::Got_Error(@_); # The connection was probably cleared, so update the scoreboard. $_[KERNEL]->call( $_[SESSION], 'UpdateScoreboard' ); return $rv; } # Closes the connection sub Request_Close { # Call the super class method. my $rv = POE::Component::Server::SimpleHTTP::Request_Close(@_); # The connection was probably cleared, so update the scoreboard. $_[KERNEL]->call( $_[SESSION], 'UpdateScoreboard' ); return $rv; } # End of module 1; __END__ =head1 NAME POE::Component::Server::SimpleHTTP::PreFork - PreForking support for SimpleHTTP =head1 SYNOPSIS use POE; use POE::Component::Server::SimpleHTTP::PreFork; # Start the server! POE::Component::Server::SimpleHTTP::PreFork->new( 'ALIAS' => 'HTTPD', 'ADDRESS' => '192.168.1.1', 'PORT' => 11111, 'HOSTNAME' => 'MySite.com', 'HANDLERS' => [ { 'DIR' => '^/bar/.*', 'SESSION' => 'HTTP_GET', 'EVENT' => 'GOT_BAR', }, { 'DIR' => '^/$', 'SESSION' => 'HTTP_GET', 'EVENT' => 'GOT_MAIN', }, { 'DIR' => '^/foo/.*', 'SESSION' => 'HTTP_GET', 'EVENT' => 'GOT_NULL', }, { 'DIR' => '.*', 'SESSION' => 'HTTP_GET', 'EVENT' => 'GOT_ERROR', }, ], # In the testing phase... 'SSLKEYCERT' => [ 'public-key.pem', 'public-cert.pem' ], # In the testing phase... 'FORKHANDLERS' => { 'HTTP_GET' => 'FORKED' }, 'MINSPARESERVERS' => 5, 'MAXSPARESERVERS' => 10, 'MAXCLIENTS' => 256, 'STARTSERVERS' => 10, ) or die 'Unable to create the HTTP Server'; =head1 ABSTRACT Subclass of SimpleHTTP for PreForking support =head1 New Constructor Options =over 5 =item C An integer that tells the server how many spares should be in the pool at any given time. Processes are forked off at a rate of 1 a second until this limit is met. =item C An integer that tells the server the maximum number of spares that may be in the pool at any given time. It is possible for more than this number of spares to exist, but at the very least the parent will stop forking requests off and the children will start to die eventually. If this value is less than MINSPARESERVERS then it is set to MINSPARESERVERS + 1. =item C An integer that tells the server the maximum number of clients that will be created. After this limit is reached, no more spares will be forked, even if the number drops below MINSPARESERVERS. =item C An integer that tells the server how many processes to prefork at startup. =item C A HASH where the keys are sessions and the values are events. When a child forks, before it begins accepting connections it will call these events on the specified sessions. This allows you to setup per-process resources (such as database connections, ldap connects, etc). These events will never be called for the parent. =back =head2 New Events =over 4 =item C Returns true if you are inside a child, false if you are in the parent. =item C This event accepts 2 arguments: the session + event to send the response to. This even will send back the current FORKHANDLERS hash ( deep-closed via Storable::dclone ). The resulting hash can be played around to your tastes, then once you are done... =item C This event accepts only one argument: reference to FORKHANDLERS hash. BEWARE: this event is disabled in a forked child. =back =head1 Miscellaneous Notes BEWARE: HANDLERS munging is disabled in a forked child. Also, handlers changed in the parent will not appear in the already forked children. BEWARE: for a child, calling {STOP,START}LISTEN does not {destroy,recreate} the SOCKETFACTORY like it does in the parent. Instead, the child will {pause,resume} accepting connections on the current SOCKETFACTORY. Also, {STOP,START}LISTEN does not have any effect on the scoreboard calculations: this child will still be marked a spare if it finishes all its requests. The shutdown event is altered a little bit GRACEFUL -> sends a TERM signal to all remaining children and waits for their death NOARGS -> kills all remaining children with prejudice Keep in mind that being forked means any global data is not shared between processes and etc. Please see perlfork for all the implications on your platform. =head1 New Compile-time constants Checking spares every second may be a bit too much for you. You can override this behavior by doing this: sub POE::Component::Server::SimpleHTTP::PreFork::CHECKSPARES_INTERVAL () { 10 } use POE::Component::Server::SimpleHTTP::PreFork; If the prefork failed because it could not obtain shared memory for the scoreboard, then if retries after 5 seconds. You can override this behavior by doing this: sub POE::Component::Server::SimpleHTTP::PreFork::PREFORK_INTERVAL () { 10 } use POE::Component::Server::SimpleHTTP::PreFork; If you would like to see the contents of the scoreboard every second then do this: sub POE::Component::Server::SimpleHTTP::PreFork::DEBUGSB () { 1 } use POE::Component::Server::SimpleHTTP::PreFork; =head2 EXPORT Nothing. =head1 SEE ALSO L =head1 AUTHOR Apocalypse Eapocal@cpan.orgE Stephen Butler Estephen.butler@gmail.comE =head1 COPYRIGHT AND LICENSE Copyright 2006 by Apocalypse + Stephen Butler This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut