package HTTP::Proxy::Engine::ScoreBoard;
$HTTP::Proxy::Engine::ScoreBoard::VERSION = '0.304';
use strict;
use POSIX ":sys_wait_h"; # WNOHANG
use Fcntl qw(LOCK_UN LOCK_EX);
use IO::Handle;
use File::Temp;
use HTTP::Proxy;
our @ISA = qw( HTTP::Proxy::Engine );
our %defaults = (
start_servers => 4, # start this many, and don't go below
max_clients => 12, # don't go above
max_requests_per_child => 250, # just in case there's a leak
min_spare_servers => 1, # minimum idle (if 0, never start new)
max_spare_servers => 12, # maximum idle (should be "single browser max")
verify_delay => 60, # minimum time between kids verification
);
__PACKAGE__->make_accessors(
qw(
kids select status_read status_write scoreboard tempfile
verify_live_kids_time last_active_time last_fork_time
),
keys %defaults
);
sub start {
my $self = shift;
$self->kids( {} );
# set up the communication pipe
$self->status_read( IO::Handle->new() );
$self->status_write( IO::Handle->new() );
pipe( $self->status_read(), $self->status_write() )
or die "Can't create pipe: $!";
$self->status_write()->autoflush(1);
$self->select( IO::Select->new( $self->status_read() ) );
setpgrp; # set as group leader
# scoreboard information
$self->verify_live_kids_time( time );
$self->last_active_time( time );
$self->last_fork_time( time );
$self->scoreboard( '' );
# lockfile information
$self->tempfile(
File::Temp->new( UNLINK => 0, TEMPLATE => 'http-proxy-XXXX' ) );
$self->proxy()->log( HTTP::Proxy::ENGINE, "ENGINE",
"Using " . $self->tempfile()->filename() . " as lockfile" );
}
my %status = ( A => 'Acccept', B => 'Busy', I => 'Idle' );
sub run {
my $self = shift;
my $proxy = $self->proxy();
my $kids = $self->kids();
## first phase: update scoreboard
if ( $self->select()->can_read(1) ) {
$self->status_read()->sysread( my $buf, 50 ) > 0 # read first 10 changes
or die "bad read"; # FIXME
while ( length $buf ) {
my ( $pid, $status ) = unpack "NA", substr( $buf, 0, 5, "" );
$proxy->log( HTTP::Proxy::ENGINE, 'ENGINE',
"Child process $pid updated to $status ($status{$status})" );
$kids->{$pid} = $status;
}
$self->last_active_time(time);
}
{
my $new = join "", values %$kids;
if ( $new ne $self->scoreboard() ) {
$proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', "ScoreBoard = $new" );
$self->scoreboard($new);
}
}
## second phase: delete dead kids
while ( ( my $kid = waitpid( -1, WNOHANG ) ) > 0 ) {
$proxy->{conn}++; # Cannot use the interface for RO attributes
$proxy->log( HTTP::Proxy::PROCESS, 'PROCESS',
"Reaped child process $kid" );
$proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" );
delete $kids->{$kid};
}
## third phase: verify live kids
if ( time > $self->verify_live_kids_time() + $self->verify_delay() ) {
for my $kid ( keys %$kids ) {
next if kill 0, $kid;
# shouldn't happen normally
$proxy->log( HTTP::Proxy::ERROR, "ENGINE",
"Child process $kid found missing" );
delete $kids->{$kid};
}
$self->verify_live_kids_time(time);
}
## fourth phase: launch kids
my @idlers = grep $kids->{$_} eq "I", keys %$kids;
if (
(
@idlers < $self->min_spare_servers() # not enough idlers
or keys %$kids < $self->start_servers() # not enough overall
)
and keys %$kids < $self->max_clients() # not too many please
and time > $self->last_fork_time() # not too fast please
)
{
my $child = fork();
if ( !defined $child ) {
$proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" );
}
else {
if ($child) {
$proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
"Forked child process $child" );
$kids->{$child} = "I";
$self->last_fork_time(time);
}
else { # child process
$self->_run_child();
exit; # we're done
}
}
}
elsif (
(
@idlers > $self->max_spare_servers() # too many idlers
or @idlers > $self->min_spare_servers() # too many lazy idlers
and time > $self->last_active_time + $self->verify_delay()
)
and keys %$kids > $self->start_servers() # not too few please
)
{
my $victim = $idlers[ rand @idlers ];
$proxy->log( HTTP::Proxy::ENGINE, "ENGINE",
"Killing idle child process $victim" );
kill INT => $victim; # pick one at random
$self->last_active_time(time);
}
}
sub stop {
my $self = shift;
my $kids = $self->kids();
my $proxy = $self->proxy();
kill 'INT' => keys %$kids;
# wait for remaining children
while (%$kids) {
my $pid = waitpid( -1, WNOHANG );
next unless $pid;
$proxy->{conn}++; # WRONG for this engine!
delete $kids->{$pid};
$proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
"Reaped child process $pid" );
$proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" );
}
# remove the temporary file
unlink $self->tempfile()->filename() or do {
$proxy->log( HTTP::Proxy::ERROR, "ERROR",
"Can't unlink @{[ $self->tempfile()->filename() ]}: $!" );
};
}
sub _run_child {
my $self = shift;
my $proxy = $self->proxy();
my $daemon = $proxy->daemon();
my $status_write = $self->status_write();
open my $lockfh, $self->tempfile()->filename() or do {
$proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot open lock file: $!" );
exit;
};
my $did = 0; # processed count
while ( ++$did <= $self->max_requests_per_child() ) {
flock $lockfh, LOCK_EX or do {
$proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot get flock: $!" );
exit;
};
last unless $proxy->loop();
5 == syswrite $status_write, pack "NA", $$, "A" # go accept
or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status A: short write");
my $slave = $daemon->accept() or do {
$proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot accept: $!");
exit;
};
flock $lockfh, LOCK_UN or do {
$proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot unflock: $!" );
exit;
};
5 == syswrite $status_write, pack "NA", $$, "B" # go busy
or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status B: short write");
$slave->autoflush(1);
$proxy->serve_connections($slave); # the real work is done here
close $slave;
5 == syswrite $status_write, pack "NA", $$, "I" # go idle
or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status I: short write");
}
}
1;
__END__
=head1 NAME
HTTP::Proxy::Engine::ScoreBoard - A scoreboard-based HTTP::Proxy engine
=head1 SYNOPSIS
my $proxy = HTTP::Proxy->new( engine => 'ScoreBoard' );
=head1 DESCRIPTION
This module provides a scoreboard-based engine to L<HTTP::Proxy>.
=head1 METHODS
The module defines the following methods, used by L<HTTP::Proxy> main loop:
=over 4
=item start()
Initialise the engine.
=item run()
Implements the forking logic: a new process is forked for each new
incoming TCP connection.
=item stop()
Reap remaining child processes.
=back
=head1 SEE ALSO
L<HTTP::Proxy>, L<HTTP::Proxy::Engine>.
=head1 AUTHOR
Philippe "BooK" Bruhat, C<< <book@cpan.org> >>.
Many thanks to Randal L. Schwartz for his help in implementing this module.
=head1 COPYRIGHT
Copyright 2005-2015, Philippe Bruhat.
=head1 LICENSE
This module is free software; you can redistribute it or modify it under
the same terms as Perl itself.
=cut