File Coverage

blib/lib/Net/Server/PreFork.pm

Criterion	Covered	Total	%
statement	131	263	49.8
branch	37	128	28.9
condition	9	32	28.1
subroutine	17	30	56.6
pod	7	15	46.6
total	201	468	42.9

# -*- perl -*-
#
#  Net::Server::PreFork - Net::Server personality
#
#  Copyright (C) 2001-2022
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::PreFork;

use strict;
use base qw(Net::Server::PreForkSimple);
use Net::Server::SIG qw(register_sig check_sigs);
use POSIX qw(WNOHANG);
use IO::Select ();
use Time::HiRes qw(time);

sub net_server_type { __PACKAGE__ }

sub options {
    my $self = shift;
    my $ref  = $self->SUPER::options(@_);
    my $prop = $self->{'server'};
    $ref->{$_} = \$prop->{$_} for qw(min_servers min_spare_servers max_spare_servers spare_servers
                                     check_for_waiting child_communication check_for_spawn min_child_ttl);
    return $ref;
}


sub post_configure {
    my $self = shift;
    my $prop = $self->{'server'};
    $self->SUPER::post_configure;

    my $d = {
        # max_servers is set in the PreForkSimple server and defaults to 50
        min_servers       => 5,    # min num of servers to always have running
        min_spare_servers => 2,    # min num of servers just sitting there
        max_spare_servers => 10,   # max num of servers just sitting there
        check_for_waiting => 10,   # how often to see if children laying around
        check_for_spawn   => 30,   # how often to see if more children are needed
        min_child_ttl     => 10,   # min time between starting a child and killing one
    };
    $prop->{'min_servers'} = $prop->{'max_servers'}
        if !!defined($prop->{'min_servers'}) && $d->{'min_servers'} > $prop->{'max_servers'};
    $prop->{'max_spare_servers'} = $prop->{'max_servers'} - 1
        if !defined($prop->{'max_spare_servers'}) && $d->{'max_spare_servers'} >= $prop->{'max_servers'};
    if (! defined $prop->{'min_spare_servers'}) {
        my $min = defined($prop->{'min_servers'}) ? $prop->{'min_servers'} : $d->{'min_servers'};
        $prop->{'min_spare_servers'} = $min if $prop > $min;
    }

    foreach (keys %$d){
        $prop->{$_} = $d->{$_} if !defined($prop->{$_}) || $prop->{$_} !~ /^\d+(?:\.\d+)?$/;
    }

    if( $prop->{'max_spare_servers'} >= $prop->{'max_servers'} ){
        $self->fatal("Error: \"max_spare_servers\" must be less than \"max_servers\"");
    }

    if ($prop->{'min_spare_servers'}) {
        $self->fatal("Error: \"min_spare_servers\" ($prop->{'min_spare_servers'}) must be less than \"$_\" ($prop->{$_})")
            for grep {$prop->{'min_spare_servers'} > $prop->{$_}} qw(min_servers max_spare_servers);
    }
}


sub loop {
    my $self = shift;
    my $prop = $self->{'server'};

    pipe(my $read, my $write); # get ready for child->parent communication
    $read->autoflush(1);
    $write->autoflush(1);
    $prop->{'_READ'}  = $read;
    $prop->{'_WRITE'} = $write;

    # get ready for children
    $prop->{'child_select'} = IO::Select->new($read);
    $prop->{'children'} = {};
    $prop->{'reaped_children'} = {};
    if ($ENV{'HUP_CHILDREN'}) {
        foreach my $line (split /\n/, $ENV{'HUP_CHILDREN'}) {
            my ($pid, $status) = ($line =~ /^(\d+)\t(\w+)$/) ? ($1, $2) : next;
            $prop->{'children'}->{$pid} = {status => $status, hup => 1};
        }
    }

    $prop->{'tally'} = {
        time       => time(),
        waiting    => scalar(grep {$_->{'status'} eq 'waiting'}    values %{ $prop->{'children'} }),
        processing => scalar(grep {$_->{'status'} eq 'processing'} values %{ $prop->{'children'} }),
        dequeue    => scalar(grep {$_->{'status'} eq 'dequeue'}    values %{ $prop->{'children'} }),
    };

    my $start = $prop->{'min_servers'};
    $self->log(3, "Beginning prefork ($start processes)");
    $self->run_n_children($start);

    $self->run_parent;
}


sub kill_n_children {
    my ($self, $n) = @_;
    my $prop = $self->{'server'};
    return unless $n > 0;

    my $time = time;
    return unless $time - $prop->{'last_kill'} > 10;
    $prop->{'last_kill'} = $time;

    $self->log(3, "Killing \"$n\" children");

    foreach my $pid (keys %{ $prop->{'children'} }){
        # Only kill waiting children
        # XXX: This is race condition prone as the child may have
        # started handling a connection, but will have to do for now
        my $child = $prop->{'children'}->{$pid};
        next if $child->{'status'} ne 'waiting';

        $n--;

        if (! kill('HUP', $pid)) {
            $self->delete_child($pid);
        }

        last if $n <= 0;
    }
}

sub run_n_children {
    my ($self, $n) = @_;
    my $prop  = $self->{'server'};
    return unless $n > 0;

    $self->run_n_children_hook($n);

    my ($parentsock, $childsock);
    $self->log(3, "Starting \"$n\" children");
    $prop->{'last_start'} = time();

    for (1 .. $n) {

        if ($prop->{'child_communication'}) {
            require IO::Socket::UNIX;
            ($parentsock, $childsock) = IO::Socket::UNIX->socketpair(IO::Socket::AF_UNIX, IO::Socket::SOCK_STREAM, IO::Socket::PF_UNSPEC);
        }

        $self->pre_fork_hook;
        local $!;
        my $pid = fork;
        if (! defined $pid) {
            if ($prop->{'child_communication'}) {
                $parentsock->close();
                $childsock->close();
            }
            $self->fatal("Bad fork [$!]");
        }

        if ($pid) { # parent
            if( $prop->{'child_communication'} ){
                $prop->{'child_select'}->add($parentsock);
                $prop->{'children'}->{$pid}->{'sock'} = $parentsock;
            }

            $prop->{'children'}->{$pid}->{'status'} = 'waiting';
            $prop->{'tally'}->{'waiting'}++;
            $self->register_child($pid, 'prefork');

        } else { # child
            if ($prop->{'child_communication'}) {
                $prop->{'parent_sock'} = $childsock;
            }
            $self->run_child;
        }
    }
}

sub run_n_children_hook {}

sub run_child {
    my $self = shift;
    my $prop = $self->{'server'};

    $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub {
        $self->child_finish_hook;
        exit;
    };
    $SIG{'PIPE'} = 'IGNORE';
    $SIG{'CHLD'} = 'DEFAULT';
    $SIG{'HUP'}  = sub {
        if (! $prop->{'connected'}) {
            $self->child_finish_hook;
            exit;
        }
        $prop->{'SigHUPed'} = 1;
    };

    # Open in child at start
    if ($prop->{'serialize'} eq 'flock') {
        open $prop->{'lock_fh'}, ">", $prop->{'lock_file'}
            or $self->fatal("Couldn't open lock file \"$prop->{'lock_file'}\"[$!]");
    }

    $self->log(4, "Child Preforked ($$)");

    delete @{ $prop }{qw(children tally last_start last_process)};

    $self->child_init_hook;
    my $write = $prop->{'_WRITE'};

    while ($self->accept()) {
        $prop->{'connected'} = 1;
        print $write "$$ processing\n";

        my $ok = eval { $self->run_client_connection; 1 };
        if (! $ok) {
            print $write "$$ exiting\n";
            die $@;
        }

        last if $self->done;

        $prop->{'connected'} = 0;
        print $write "$$ waiting\n";
    }

    $self->child_finish_hook;

    print $write "$$ exiting\n";
    exit;
}


sub run_parent {
    my $self = shift;
    my $prop = $self->{'server'};
    my $id;

    $self->log(4, "Parent ready for children.");
    my $read_fh = $prop->{'_READ'};

    @{ $prop }{qw(last_checked_for_dead last_checked_for_waiting last_checked_for_dequeue last_process last_kill)} = (time) x 5;

    my $reaper = sub {
        while ( defined( my $chld = waitpid( -1, WNOHANG ) ) ) {
            last unless $chld > 0;
            $self->{'reaped_children'}->{$chld} = $?
                ; # We'll deal with this in coordinate_children to avoid a race
        }
    };

    register_sig(
        PIPE => 'IGNORE',
        INT  => sub { $self->server_close() },
        TERM => sub { $self->server_close() },
        HUP  => sub { $self->sig_hup() },
        CHLD => $reaper,
        QUIT => sub { $self->{'server'}->{'kind_quit'} = 1; $self->server_close() },
        TTIN => sub { $self->{'server'}->{$_}++ for qw(min_servers max_servers); $self->log(3, "Increasing server count ($self->{'server'}->{'max_servers'})") },
        TTOU => sub { $self->{'server'}->{$_}-- for qw(min_servers max_servers); $self->log(3, "Decreasing server count ($self->{'server'}->{'max_servers'})") },
    );

    $self->register_sig_pass;

    if ($ENV{'HUP_CHILDREN'}) {
        $reaper->();
    }

    while (1) {
        ### Wait to read.
        ## Normally it is not good to do selects with
        ## getline or <$fh> but this is controlled output
        ## where everything that comes through came from us.
        my @fh = $prop->{'child_select'}->can_read($prop->{'check_for_waiting'});
        if (check_sigs()) {
            last if $prop->{'_HUP'};
        }

        $self->idle_loop_hook(\@fh);

        if (! @fh) {
            $self->coordinate_children();
            next;
        }

        foreach my $fh (@fh) {
            if ($fh != $read_fh) { # preforking server data
                $self->child_is_talking_hook($fh);
                next;
            }

            my $line = <$fh>;
            next if ! defined $line;

            last if $self->parent_read_hook($line); # optional test by user hook

            # child should say "$pid status\n"
            next if $line !~ /^(\d+)\ +(waiting|processing|dequeue|exiting)$/;
            my ($pid, $status) = ($1, $2);

            if (my $child = $prop->{'children'}->{$pid}) {
                if ($status eq 'exiting') {
                    $self->delete_child($pid);

                } else {
                    # Decrement tally of state pid was in (plus sanity check)
                    my $old_status = $child->{'status'}    || $self->log(2, "No status for $pid when changing to $status");
                    --$prop->{'tally'}->{$old_status} >= 0 || $self->log(2, "Tally for $status < 0 changing pid $pid from $old_status to $status");

                    $child->{'status'} = $status;
                    ++$prop->{'tally'}->{$status};

                    $prop->{'last_process'} = time() if $status eq 'processing';
                }
            }
        }
        $self->coordinate_children();
    }
}

sub run_dequeue {
    my $self = shift;
    $self->SUPER::run_dequeue;
    $self->{'server'}->{'tally'}->{'dequeue'}++;
}

sub cleanup_dead_child_hook { return; }

sub coordinate_children {
    my $self = shift;
    my $prop = $self->{'server'};
    my $time = time();

    # deleted SIG{'CHLD'} reaped children
    foreach my $pid (keys %{ $self->{'reaped_children'} }) {
        my $exit = delete $self->{'reaped_children'}->{$pid}; # delete each pid one by one to avoid another race
        next if ! $prop->{'children'}->{$pid};
        $self->delete_child($pid, $exit);
    }

    # re-tally the possible types (only twice a minute)
    # this might not be even necessary but is a nice sanity check
    my $tally = $prop->{'tally'} ||= {};
    if ($time - $tally->{'time'} > $prop->{'check_for_spawn'}) {
        my $w = $tally->{'waiting'};
        my $p = $tally->{'processing'};
        $tally = $prop->{'tally'} = {
            time       => $time,
            waiting    => 0,
            processing => 0,
            dequeue    => 0,
        };
        foreach (values %{ $prop->{'children'} }) {
            $tally->{$_->{'status'}}++;
        }
        $w -= $tally->{'waiting'};
        $p -= $tally->{'processing'};
        $self->log(3, "Processing diff ($p), Waiting diff ($w)") if $p || $w;
    }

    my $total = $tally->{'waiting'} + $tally->{'processing'};

    if ($total < $prop->{'min_servers'}) {
        $self->run_n_children($prop->{'min_servers'} - $total); # need more min_servers

    } elsif ($tally->{'waiting'} < $prop->{'min_spare_servers'}
             && $total < $prop->{'max_servers'}) { # need more min_spare_servers (up to max_servers)
        my $n1 = $prop->{'min_spare_servers'} - $tally->{'waiting'};
        my $n2 = $prop->{'max_servers'} - $total;
        $self->run_n_children(($n2 > $n1) ? $n1 : $n2);
    }

    # check to see if we should kill off some children
    if ($time - $prop->{'last_checked_for_waiting'} > $prop->{'check_for_waiting'}) {
        $prop->{'last_checked_for_waiting'} = $time;

        # need fewer max_spare_servers (down to min_servers)
        if ($tally->{'waiting'} > $prop->{'max_spare_servers'}
            && $total > $prop->{'min_servers'}) {

            ### see if we haven't started any in the last ten seconds
            if ($time - $prop->{'last_start'} > $prop->{'min_child_ttl'}) {
                my $n1 = $tally->{'waiting'} - $prop->{'max_spare_servers'};
                my $n2 = $total - $prop->{'min_servers'};
                $self->kill_n_children(($n2 > $n1) ? $n1 : $n2);
            }

        } elsif ($total > $prop->{'max_servers'}) { # how did this happen?
            $self->kill_n_children($total - $prop->{'max_servers'});
        }
    }

    # periodically make sure children are alive
    if ($time - $prop->{'last_checked_for_dead'} > $prop->{'check_for_dead'}) {
        $prop->{'last_checked_for_dead'} = $time;
        foreach my $pid (keys %{ $prop->{'children'} }) {
            if( ! kill(0, $pid) ) {
              $self->cleanup_dead_child_hook( $prop->{'children'}->{$pid} );
              $self->delete_child($pid);
            }
        }
    }

    # take us down to min if we haven't had a request in a while
    if ($time - $prop->{'last_process'} > 30 && $tally->{'waiting'} > $prop->{'min_spare_servers'}) {
        my $n1 = $tally->{'waiting'} - $prop->{'min_spare_servers'};
        my $n2 = $total - $prop->{'min_servers'};
        $self->kill_n_children( ($n2 > $n1) ? $n1 : $n2 );
    }

    # periodically check to see if we should clear the queue
    if (defined $prop->{'check_for_dequeue'}) {
        if ($time - $prop->{'last_checked_for_dequeue'} > $prop->{'check_for_dequeue'}) {
            $prop->{'last_checked_for_dequeue'} = $time;
            if (defined($prop->{'max_dequeue'})
                && $tally->{'dequeue'} < $prop->{'max_dequeue'}) {
                $self->run_dequeue();
            }
        }
    }
}

### delete_child and other modifications contributed by Rob Mueller
sub delete_child {
    my ($self, $pid, $exit) = @_;
    my $prop = $self->{'server'};

    my $child = $prop->{'children'}->{$pid};
    if (! $child) {
        $self->log(2, "Attempt to delete already deleted child $pid");
        return;
    }

    return if ! exists $prop->{'children'}->{$pid}; # Already gone?

    # This means there was some sort of abnormal exit for the child, like a
    # segfault.
    if ($exit) {
        my $status  = $exit >> 8;
        my $signal  = $exit & 127;
        my $message = "Child process $pid exited with status $status";
        $message .= " - signal was $signal"
            if $signal;

        $self->log(1, $message);
    }

    my $status = $child->{'status'}    || $self->log(2, "No status for $pid when deleting child");
    --$prop->{'tally'}->{$status} >= 0 || $self->log(2, "Tally for $status < 0 deleting pid $pid");
    $prop->{'tally'}->{'time'} = 0 if $child->{'hup'};

    $self->SUPER::delete_child($pid);
}

sub parent_read_hook {}

sub child_is_talking_hook {}

1;

__END__