view release on metacpan or  search on metacpan

t/74-supervisor-edges.t  view on Meta::CPAN

#!perl
use strict;
use warnings;
use lib 't/lib';
use Test::More;
use HMTest qw(free_ports quiet_child server_reap);
use IO::Socket::INET;
use Time::HiRes ();
use File::Temp ();
use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);
use POSIX qw(WNOHANG);
use Hyperman;

# The supervisor's edges: a HUP recycle, a worker that stops ticking, the
# caller's alarm met on a tick, USR1 at a pool without a scoreboard, a USR2
# re-exec with a second USR2 while the successor starts, a handover
# environment naming a descriptor that is not a listener and one for a
# listener the new config dropped, a pid file in a directory that cannot be
# written, a chunked body past the spill mark with TMPDIR unset, and a
# listener starved of descriptors.

plan skip_all => 'signals and fork are not Windows' if $^O eq 'MSWin32';
my ($pa, $pb, $pc, $pd, $pe, $pf, $pg) = free_ports(7);
plan skip_all => 'no free loopback ports' unless $pg;
my $dir = File::Temp::tempdir(CLEANUP => 1);

sub connect_to {
    my $port = shift;
    for (1 .. 80) {
        my $s = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
        return $s if $s;
        Time::HiRes::sleep(0.1);
    }
    return;
}
sub get {
    my ($port, $path) = @_;
    my $s = connect_to($port) or return '';
    $s->syswrite("GET $path HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n");
    my $buf = '';
    eval { local $SIG{ALRM} = sub { die "timeout\n" }; alarm 5; while (my $n = $s->sysread(my $c, 65536)) { $buf .= $c } alarm 0 };
    return $buf;
}
sub body { my $r = shift; (split /\r\n\r\n/, $r, 2)[1] // '' }
sub slurp { my $f = shift; -f $f ? do { local (@ARGV, $/) = ($f); <> } // '' : '' }
sub wait_for { my ($file, $re, $secs) = @_; for (1 .. ($secs || 5) * 10) { my $t = slurp($file); return $t if $t =~ $re; Time::HiRes::sleep(0.1) } return slurp($file) }
sub wait_gone { my $pid = shift; for (1 .. 100) { return 1 if kill(0, $pid) == 0; Time::HiRes::sleep(0.1) } return 0 }
sub pids_of { my ($port, $n) = @_; my %p; for (1 .. 60) { my $b = body(get($port, '/pid')); $p{$1} = 1 if $b =~ /^w(\d+)/; last if keys %p >= $n } return sort keys %p }

my $app = sub {
    my $env = shift;
    my $p = $env->{PATH_INFO};
    if ($p eq '/pid') { return [ 200, [], [ "w$$" ] ] }
    if ($p eq '/len') {
        my $body = '';
        my $in = $env->{'psgi.input'};
        while ($in->read(my $c, 65536)) { $body .= $c }
        return [ 200, [], [ 'len=' . length($body) . ';' . ref($in) ] ];
    }
    [ 200, [], ['x'] ];
};

# --- HUP: fresh workers, the old ones drained ---
{
    my $pid = fork // die "fork: $!";
    if (!$pid) { quiet_child(); Hyperman->run(app => $app, host => '127.0.0.1', port => $pa, workers => 2); exit 0 }
    my @old = pids_of($pa, 2);
    ok(scalar @old >= 1, 'the pool answers');
    kill 'HUP', $pid;
    my @new;
    for (1 .. 50) { @new = pids_of($pa, 2); last if @new && !grep { my $n = $_; grep { $_ == $n } @old } @new; Time::HiRes::sleep(0.2) }
    ok(@new && !grep({ my $n = $_; grep { $_ == $n } @old } @new), 'after a HUP fresh workers answer') or diag "old @old new @new";
    ok(!grep({ !wait_gone($_) } @old), 'and the old ones are gone');
    kill 'TERM', $pid;
    server_reap($pid);
}

# --- a worker that stops updating its row, and the caller's alarm on a tick ---
{
    my $pid = fork // die "fork: $!";
    if (!$pid) { quiet_child(stderr => "$dir/wedge.err"); alarm 14; Hyperman->run(app => $app, host => '127.0.0.1', port => $pb, workers => 2); exit 0 }
    my @w = pids_of($pb, 2);
    ok(scalar @w >= 1, 'the pool to be wedged answers');
    kill 'STOP', $w[0];
    like(wait_for("$dir/wedge.err", qr/wedged/, 14), qr/worker $w[0] is alive but has not updated its scoreboard row for 9 seconds: wedged\?/, 'a worker whose row stops moving is reported after three ticks');
    kill 'CONT', $w[0];
    my $st = server_reap($pid);
    is($st & 127, 14, 'the alarm met on a tick drains the pool and is then delivered');
}

# --- USR1 at a pool with no scoreboard: every worker prints its own line ---
{
    my $pid = fork // die "fork: $!";
    if (!$pid) {
        quiet_child();
        $ENV{HYPERMAN_NO_SA_ABI} = 1;
        exec $^X, '-Mblib', '-MHyperman', '-e', "Hyperman->run(app => sub { [200, [], ['x']] }, host => '127.0.0.1', port => $pc, workers => 2, error_log => '$dir/usr1.err')";
        exit 1;
    }
    like(get($pc, '/'), qr{^HTTP/1\.1 200}, 'the arena-less pool answers');
    Time::HiRes::sleep(0.5);
    kill 'USR1', $pid;
    my $log = wait_for("$dir/usr1.err", qr/requests=.*\n.*requests=/s);
    is(scalar(() = $log =~ /Hyperman worker \d+: requests=/g), 2, 'USR1 is passed to both workers, each printing its line');
    kill 'TERM', $pid;