1package HTTP::Proxy::Engine::ScoreBoard; 2use strict; 3use POSIX ":sys_wait_h"; # WNOHANG 4use Fcntl qw(LOCK_UN LOCK_EX); 5use IO::Handle; 6use File::Temp; 7use HTTP::Proxy; 8 9our @ISA = qw( HTTP::Proxy::Engine ); 10our %defaults = ( 11 start_servers => 4, # start this many, and don't go below 12 max_clients => 12, # don't go above 13 max_requests_per_child => 250, # just in case there's a leak 14 min_spare_servers => 1, # minimum idle (if 0, never start new) 15 max_spare_servers => 12, # maximum idle (should be "single browser max") 16 verify_delay => 60, # minimum time between kids verification 17); 18 19__PACKAGE__->make_accessors( 20 qw( 21 kids select status_read status_write scoreboard tempfile 22 verify_live_kids_time last_active_time last_fork_time 23 ), 24 keys %defaults 25); 26 27sub start { 28 my $self = shift; 29 $self->kids( {} ); 30 31 # set up the communication pipe 32 $self->status_read( IO::Handle->new() ); 33 $self->status_write( IO::Handle->new() ); 34 pipe( $self->status_read(), $self->status_write() ) 35 or die "Can't create pipe: $!"; 36 $self->status_write()->autoflush(1); 37 $self->select( IO::Select->new( $self->status_read() ) ); 38 setpgrp; # set as group leader 39 40 # scoreboard information 41 $self->verify_live_kids_time( time ); 42 $self->last_active_time( time ); 43 $self->last_fork_time( time ); 44 $self->scoreboard( '' ); 45 46 # lockfile information 47 $self->tempfile( 48 File::Temp->new( UNLINK => 0, TEMPLATE => 'http-proxy-XXXX' ) ); 49 $self->proxy()->log( HTTP::Proxy::ENGINE, "ENGINE", 50 "Using " . $self->tempfile()->filename() . " as lockfile" ); 51} 52 53my %status = ( A => 'Acccept', B => 'Busy', I => 'Idle' ); 54sub run { 55 my $self = shift; 56 my $proxy = $self->proxy(); 57 my $kids = $self->kids(); 58 59 ## first phase: update scoreboard 60 if ( $self->select()->can_read(1) ) { 61 $self->status_read()->sysread( my $buf, 50 ) > 0 # read first 10 changes 62 or die "bad read"; # FIXME 63 while ( length $buf ) { 64 my ( $pid, $status ) = unpack "NA", substr( $buf, 0, 5, "" ); 65 $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', 66 "Child process $pid updated to $status ($status{$status})" ); 67 $kids->{$pid} = $status; 68 } 69 $self->last_active_time(time); 70 } 71 72 { 73 my $new = join "", values %$kids; 74 if ( $new ne $self->scoreboard() ) { 75 $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', "ScoreBoard = $new" ); 76 $self->scoreboard($new); 77 } 78 } 79 80 ## second phase: delete dead kids 81 while ( ( my $kid = waitpid( -1, WNOHANG ) ) > 0 ) { 82 $proxy->{conn}++; # Cannot use the interface for RO attributes 83 $proxy->log( HTTP::Proxy::PROCESS, 'PROCESS', 84 "Reaped child process $kid" ); 85 $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", 86 keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" ); 87 delete $kids->{$kid}; 88 } 89 90 ## third phase: verify live kids 91 if ( time > $self->verify_live_kids_time() + $self->verify_delay() ) { 92 for my $kid ( keys %$kids ) { 93 next if kill 0, $kid; 94 95 # shouldn't happen normally 96 $proxy->log( HTTP::Proxy::ERROR, "ENGINE", 97 "Child process $kid found missing" ); 98 delete $kids->{$kid}; 99 } 100 $self->verify_live_kids_time(time); 101 } 102 103 ## fourth phase: launch kids 104 my @idlers = grep $kids->{$_} eq "I", keys %$kids; 105 if ( 106 ( 107 @idlers < $self->min_spare_servers() # not enough idlers 108 or keys %$kids < $self->start_servers() # not enough overall 109 ) 110 and keys %$kids < $self->max_clients() # not too many please 111 and time > $self->last_fork_time() # not too fast please 112 ) 113 { 114 my $child = fork(); 115 if ( !defined $child ) { 116 $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" ); 117 } 118 else { 119 if ($child) { 120 $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", 121 "Forked child process $child" ); 122 $kids->{$child} = "I"; 123 $self->last_fork_time(time); 124 } 125 else { # child process 126 $self->_run_child(); 127 exit; # we're done 128 } 129 } 130 } 131 elsif ( 132 ( 133 @idlers > $self->max_spare_servers() # too many idlers 134 or @idlers > $self->min_spare_servers() # too many lazy idlers 135 and time > $self->last_active_time + $self->verify_delay() 136 ) 137 and keys %$kids > $self->start_servers() # not too few please 138 ) 139 { 140 my $victim = $idlers[ rand @idlers ]; 141 $proxy->log( HTTP::Proxy::ENGINE, "ENGINE", 142 "Killing idle child process $victim" ); 143 kill INT => $victim; # pick one at random 144 $self->last_active_time(time); 145 } 146 147} 148 149sub stop { 150 my $self = shift; 151 my $kids = $self->kids(); 152 my $proxy = $self->proxy(); 153 154 kill 'INT' => keys %$kids; 155 156 # wait for remaining children 157 while (%$kids) { 158 my $pid = waitpid( -1, WNOHANG ); 159 next unless $pid; 160 161 $proxy->{conn}++; # WRONG for this engine! 162 163 delete $kids->{$pid}; 164 $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", 165 "Reaped child process $pid" ); 166 $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", 167 keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" ); 168 } 169 170 # remove the temporary file 171 unlink $self->tempfile()->filename() or do { 172 $proxy->log( HTTP::Proxy::ERROR, "ERROR", 173 "Can't unlink @{[ $self->tempfile()->filename() ]}: $!" ); 174 }; 175} 176 177sub _run_child { 178 my $self = shift; 179 my $proxy = $self->proxy(); 180 181 my $daemon = $proxy->daemon(); 182 my $status_write = $self->status_write(); 183 184 open my $lockfh, $self->tempfile()->filename() or do { 185 $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot open lock file: $!" ); 186 exit; 187 }; 188 189 my $did = 0; # processed count 190 191 while ( ++$did <= $self->max_requests_per_child() ) { 192 193 flock $lockfh, LOCK_EX or do { 194 $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot get flock: $!" ); 195 exit; 196 }; 197 198 last unless $proxy->loop(); 199 200 5 == syswrite $status_write, pack "NA", $$, "A" # go accept 201 or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status A: short write"); 202 203 my $slave = $daemon->accept() or do { 204 $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot accept: $!"); 205 exit; 206 }; 207 208 flock $lockfh, LOCK_UN or do { 209 $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot unflock: $!" ); 210 exit; 211 }; 212 213 5 == syswrite $status_write, pack "NA", $$, "B" # go busy 214 or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status B: short write"); 215 $slave->autoflush(1); 216 217 $proxy->serve_connections($slave); # the real work is done here 218 219 close $slave; 220 5 == syswrite $status_write, pack "NA", $$, "I" # go idle 221 or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status I: short write"); 222 } 223} 224 2251; 226 227__END__ 228 229=head1 NAME 230 231HTTP::Proxy::Engine::ScoreBoard - A scoreboard-based HTTP::Proxy engine 232 233=head1 SYNOPSIS 234 235 my $proxy = HTTP::Proxy->new( engine => 'ScoreBoard' ); 236 237=head1 DESCRIPTION 238 239This module provides a scoreboard-based engine to HTTP::Proxy. 240 241=head1 METHODS 242 243The module defines the following methods, used by HTTP::Proxy main loop: 244 245=over 4 246 247=item start() 248 249Initialise the engine. 250 251=item run() 252 253Implements the forking logic: a new process is forked for each new 254incoming TCP connection. 255 256=item stop() 257 258Reap remaining child processes. 259 260=back 261 262=head1 SEE ALSO 263 264L<HTTP::Proxy>, L<HTTP::Proxy::Engine>. 265 266=head1 AUTHOR 267 268Philippe "BooK" Bruhat, C<< <book@cpan.org> >>. 269 270Many thanks to Randal L. Schwartz for his help in implementing this module. 271 272=head1 COPYRIGHT 273 274Copyright 2005, Philippe Bruhat. 275 276=head1 LICENSE 277 278This module is free software; you can redistribute it or modify it under 279the same terms as Perl itself. 280 281=cut 282 283