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