Hyperman

 view release on metacpan or  search on metacpan

t/64-options.t  view on Meta::CPAN

SKIP: {
    skip "fork is not Windows", 2 if $^O eq "MSWin32";
    skip "no /bin/sh to lower the descriptor limit", 2 unless -x "/bin/sh";
    my $dir = File::Temp::tempdir(CLEANUP => 1);
    for my $which (qw(access_log error_log)) {
        my $file = "$dir/dup-$which";
        my $code = "my \@hold; while (open my \$fh, q{<}, q{/dev/null}) { push \@hold, \$fh } "
            . "eval { Hyperman->run(app => sub { [200, [], [q{x}]] }, host => q{127.0.0.1}, port => 0, workers => 1, $which => \\*STDOUT) }; "
            . "print STDOUT qq{err=\$\@}";
        system "/bin/sh", "-c", "ulimit -n 48 && exec $^X -Mblib -MHyperman -e '$code' >$file 2>&1";
        my $got = do { local (@ARGV, $/) = ($file); <> } // "";
        like($got, qr/err=Hyperman->run: dup $which fd: /, "a $which handle that cannot be duplicated is refused");
    }
}

done_testing;

t/69-server-edges.t  view on Meta::CPAN

    my $body = 'b' x (1024 * 1024 + 100);
    like(raw($pa, "POST /spill HTTP/1.1\r\nHost: a\r\nContent-Length: " . length($body) . "\r\nConnection: close\r\n\r\n$body", 10), qr{/spill:1048676}, 'a body past a megabyte is spilled to a file and read back whole');
}

# --- the logs ---
{
    like(raw($pb, "GET /stream HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n"), qr/s\z/, 'a streamed response on the combined log');
    like(raw($pa, "GET /stream HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n"), qr/s\z/, 'a streamed response');
    like(raw($pb, "GET /ctl HTTP/1.1\r\nHost: a\r\nUser-Agent: del\x7fete \"q\"\r\nConnection: close\r\n\r\n"), qr{/ctl:0}, 'a control byte in the agent');
    Time::HiRes::sleep(0.3);
    my $a = do { local (@ARGV, $/) = ("$dir/a.log"); <> } // '';
    like($a, qr/"bytes":null/, 'the JSON log writes null for the bytes of a stream');
    my $b = do { local (@ARGV, $/) = ("$dir/b.log"); <> } // '';
    like($b, qr/"del\\x7fete \\"q\\"" - 200 7 7 127\.0\.0\.1 127\.0\.0\.1 \d+ \d+ \d+/, 'the combined log escapes a control byte and quotes, dashes a missing header, and fills %B %b %v %e %D %T %P');
    like($b, qr/ 200 0 - 127/, 'a streamed response logs zero and a dash for its bytes');
}

# --- a hard stop: TERM during a slow request, the grace runs out ---
{
    my $s = connect_to($pb);
    $s->syswrite("GET /slow HTTP/1.1\r\nHost: a\r\n\r\n");
    Time::HiRes::sleep(0.3);
    kill 'TERM', $pidb;

t/70-pool-edges.t  view on Meta::CPAN

    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, 4096)) { $buf .= $c } alarm 0 };
    return $buf;
}
sub slurp { my $f = shift; -f $f ? do { local (@ARGV, $/) = ($f); <> } // '' : '' }
sub wait_for { my ($file, $re) = @_; for (1 .. 30) { my $t = slurp($file); return $t if $t =~ $re; Time::HiRes::sleep(0.1) } return slurp($file) }

# --- a fresh perl without the arena: the worker prints its own USR1 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 => $pa, workers => 1, error_log => '$dir/a.err')";

t/71-api-in-request.t  view on Meta::CPAN

like(body(get($pa, '/detach_bad')), qr/give it the PSGI env hashref.*no psgix\.hyperman\.conn.*malformed psgix\.hyperman\.conn/s, 'detach refuses a string, an env without a ticket, and a malformed one');
like(body(get($pa, '/detach_twice')), qr/already detached.*connection is gone/s, 'a second detach and a stale ticket are refused');
like(get($pa, '/detach_draining', 1), qr/response is still draining/, 'detach while a response drains is refused: the client reads nothing while the handler runs');
like(body(get($pa, '/stream_bad')), qr/give it the PSGI env hashref.*no usable psgix\.hyperman\.stream.*headers must be an array reference/s, 'stream refuses a string, an env without a ticket, and headers that are not a list');
my $aborted = get($pa, '/stream_abort');
like($aborted, qr/partial/, 'a stream abort leaves what was written');
unlike($aborted, qr/aborted=/, 'and the response that follows goes nowhere');
like(get($pa, '/stream_drop'), qr/dropped\z/, 'a stream handle dropped without close still ends the body');
like(body(get($pa, '/bus')), qr/big=-1;ok=[01]/, 'the bus refuses a message past the slot size');
Time::HiRes::sleep(0.3);
like(do { local (@ARGV, $/) = ("$dir/access.log"); <> } // '', qr/GET \/io_ready/, 'the access log glob received the lines');
like(do { local (@ARGV, $/) = ("$dir/stderr"); <> } // '', qr/on_worker_start callback died: hook boom/, 'a worker hook that dies is reported');
ok(-s $hook_log, 'after it ran');

kill 'TERM', $pid;
server_reap($pid);
done_testing;

t/72-tls-edges.t  view on Meta::CPAN

my $dir = File::Temp::tempdir(CLEANUP => 1);
my $made = 1;
sub sh { $made &&= system("$_[0] >/dev/null 2>&1") == 0 }
sh(qq{openssl req -x509 -newkey rsa:2048 -nodes -keyout $dir/a.key -out $dir/a.pem -days 1 -subj "/CN=localhost"});
sh(qq{openssl req -x509 -newkey rsa:2048 -nodes -keyout $dir/b.key -out $dir/b.pem -days 1 -subj "/CN=other"});
plan skip_all => 'could not create the test certificates'
    unless $made && !grep { !-s "$dir/$_" } qw(a.pem a.key b.pem b.key);

my ($port) = free_ports(1);
plan skip_all => 'no free loopback port' unless $port;
sub slurp { my $f = shift; -f $f ? do { local (@ARGV, $/) = ($f); <> } // '' : '' }
sub wait_for { my ($file, $re) = @_; for (1 .. 50) { my $t = slurp($file); return $t if $t =~ $re; Time::HiRes::sleep(0.1) } return slurp($file) }

# A run() that must refuse, in a child with stderr captured, since the TLS
# layer explains itself there before the croak.
sub refused_in_child {
    my ($name, %opts) = @_;
    my $pid = fork // die "fork: $!";
    if (!$pid) {
        quiet_child(stderr => "$dir/$name.stderr");
        my $err = eval { Hyperman->run(app => sub { [ 200, [], [] ] }, host => '127.0.0.1', port => 0, workers => 1, %opts); 'none' } // $@;

t/73-h2-edges.t  view on Meta::CPAN

    next unless $c && -x $c;
    next unless (`$c --version 2>/dev/null` || '') =~ /^Features:.*\bHTTP2\b/m;
    $curl = $c;
    last;
}
plan skip_all => 'no HTTP/2-capable curl' unless $curl;

my ($pa, $pb) = free_ports(2);
plan skip_all => 'no free loopback ports' unless $pa && $pb;
my $dir = File::Temp::tempdir(CLEANUP => 1);
sub slurp { my $f = shift; -f $f ? do { local (@ARGV, $/) = ($f); <> } // '' : '' }
sub wait_for { my ($file, $re) = @_; for (1 .. 50) { my $t = slurp($file); return $t if $t =~ $re; Time::HiRes::sleep(0.1) } return slurp($file) }

package Duck;
sub new { my ($class, %o) = @_; bless { %o }, $class }
sub on_ready { my ($self, $cb) = @_; $cb->($self); $self }
sub is_ready { 1 }
sub is_done { 1 }
sub is_failed { 0 }
sub is_cancelled { 0 }
sub get { my $self = shift; die "duck get dies\n" if $self->{dies}; $self->{value} }

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

}
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 = '';