view release on metacpan or  search on metacpan

t/73-h2-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 Hyperman;

# HTTP/2 edges: a file body lifted onto the stream and an object body
# slurped, hop-by-hop headers dropped, a header the library refuses, the
# responder's three-element form and a second call, handlers that die before
# and after producing, a response of the wrong shape, foreign and failed
# futures, a stream reset while its future is pending, a response past the
# write mark, a stream opened after parking, the upgrade's settings with
# whitespace and with a bad length, and raw frames: a preface in two writes,
# a Host beside :authority, trailers, a header block past the ceiling, and a
# GOAWAY from the client.

plan skip_all => 'HTTP/2 support not built' unless Hyperman->has_http2;
plan skip_all => 'fork is not Windows' if $^O eq 'MSWin32';
my $curl;
for my $c ('/opt/homebrew/opt/curl/bin/curl', '/usr/local/opt/curl/bin/curl', split /\n/, `which -a curl 2>/dev/null` || '') {
    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} }
sub failure { () }
sub cancel { $_[0] }
package Getliner;
sub new { my ($class, $s) = @_; bless { s => $s, done => 0 }, $class }
sub getline { my $self = shift; return undef if $self->{done}++; $self->{s} }
sub read { my $self = shift; return 0 if $self->{done}++; $_[0] = $self->{s}; length $self->{s} }
sub close { 1 }
package main;

my $note = "$dir/note";
my $keep;
open my $ffh, '>', "$dir/file.bin" or die; print $ffh 'f' x 65536; close $ffh;
my $app = sub {
    my $env = shift;
    my $p = $env->{PATH_INFO};
    my $ok = sub { [ 200, [ 'Content-Type' => 'text/plain' ], [ @_ ] ] };
    if ($p eq '/detach') { my $err = eval { Hyperman::detach($env); 'none' } // $@; return $ok->($err) }
    if ($p eq '/file') { open my $fh, '<', "$dir/file.bin" or die; return [ 200, [ 'Content-Length' => 65536 ], $fh ] }
    if ($p eq '/obj') { return [ 200, [ 'Content-Type' => 'text/plain' ], Getliner->new('from-getline') ] }
    if ($p eq '/hop') { return [ 200, [ 'Keep-Alive' => 'timeout=5', 'Proxy-Connection' => 'close', 'Transfer-Encoding' => 'chunked', 'Upgrade' => 'x', 'TE' => 'trailers', 'Connection' => 'close', 'X-Kept' => 'yes' ], ['hop'] ] }
    if ($p eq '/badhdr') { return [ 200, [ 'bad name' => 'x' ], ['bad'] ] }
    if ($p eq '/resp3') { return sub { $_[0]->([ 200, [ 'Content-Type' => 'text/plain' ], ['three'] ]) } }
    if ($p eq '/resp_twice') {
        return sub {
            my $r = shift;
            my $w = $r->([ 200, [ 'Content-Type' => 'text/plain' ] ]);
            my $err = eval { $r->([ 200, [], ['again'] ]); 'none' } // $@;
            open my $fh, '>', $note or die; print $fh $err; close $fh;
            $w->write('once'); $w->close;
        };
    }
    if ($p eq '/die_producing') { return sub { my $w = Hyperman::stream($env, 200, [ 'Content-Type' => 'text/plain' ]); $w->write('x'); $keep = $w; die "producing boom\n" } }
    if ($p eq '/die_early') { return sub { die "early boom\n" } }
    if ($p eq '/junk') { return { not => 'a response' } }
    if ($p eq '/duck') { return Duck->new(value => $ok->('duck')) }
    if ($p eq '/duck_dies') { return Duck->new(dies => 1) }
    if ($p eq '/fail') { return Hyperman::Future->fail_future("async nope\n") }
    if ($p eq '/badval') { return Hyperman::Future->done_future('not a response') }
    if ($p eq '/slow') { return Hyperman->timer(3)->then(sub { $ok->('late') }) }
    if ($p eq '/big') { return $ok->('b' x (4 * 1024 * 1024)) }
    if ($p eq '/stream_sync') {
        Hyperman->timer(0.01)->get;
        my $w = Hyperman::stream($env, 200, [ 'Content-Type' => 'text/plain' ]);
        $w->write('synced'); $w->close;
        return [ 101, [], [] ];
    }
    if ($p eq '/echo') {
        my $body = '';
        $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH} || 1 << 20);
        return $ok->('len=' . length($body));