1package t::Util;
2
3use strict;
4use warnings;
5use Digest::MD5 qw(md5_hex);
6use File::Temp qw(tempfile tempdir);
7use IO::Socket::INET;
8use IO::Socket::SSL;
9use IO::Poll qw(POLLIN POLLOUT POLLHUP POLLERR);
10use List::Util qw(shuffle);
11use List::MoreUtils qw(firstidx);
12use Net::EmptyPort qw(check_port empty_port);
13use Net::DNS::Nameserver;
14use POSIX ":sys_wait_h";
15use Path::Tiny;
16use Protocol::HTTP2::Connection;
17use Protocol::HTTP2::Constants;
18use Scope::Guard;
19use Test::More;
20use Time::HiRes qw(sleep gettimeofday tv_interval);
21use Carp;
22
23use base qw(Exporter);
24our @EXPORT = qw(
25    ASSETS_DIR
26    DOC_ROOT
27    bindir
28    run_as_root
29    server_features
30    exec_unittest
31    exec_mruby_unittest
32    exec_fuzzer
33    spawn_server
34    spawn_h2o
35    spawn_h2o_raw
36    empty_ports
37    create_data_file
38    md5_file
39    etag_file
40    prog_exists
41    run_prog
42    openssl_can_negotiate
43    curl_supports_http2
44    run_with_curl
45    h2get_exists
46    run_with_h2get
47    run_with_h2get_simple
48    one_shot_http_upstream
49    wait_debugger
50    make_guard
51    spawn_forked
52    spawn_h2_server
53    find_blackhole_ip
54    get_tracer
55    check_dtrace_availability
56    run_picotls_client
57    spawn_dns_server
58    run_fuzzer
59);
60
61use constant ASSETS_DIR => 't/assets';
62use constant DOC_ROOT   => ASSETS_DIR . "/doc_root";
63
64sub bindir {
65    $ENV{H2O_VALGRIND} || $ENV{BINARY_DIR} || '.';
66}
67
68sub run_as_root {
69    return if $< == 0;
70    exec qw(sudo -E env PERL5LIB=.), "PATH=$ENV{PATH}", $^X, $0;
71    die "failed to invoke $0 using sudo:$!";
72}
73
74sub server_features {
75    open my $fh, "-|", bindir() . "/h2o", "--version"
76        or die "failed to invoke: h2o --version:$!";
77    <$fh>; # skip h2o version
78    +{
79        map { chomp($_); split /:/, $_, 2 } <$fh>
80    };
81}
82
83sub exec_unittest {
84    my $base = shift;
85    my $fn = bindir() . "/t-00unit-$base.t";
86    plan skip_all => "unit test:$base does not exist"
87        if ! -e $fn;
88
89    if (prog_exists("memcached")) {
90        my $port = empty_port();
91        pipe my $rfh, my $wfh
92            or die "pipe failed:$!";
93        my $pid = fork;
94        die "fork failed:$!"
95            unless defined $pid;
96        if ($pid == 0) {
97            # child process
98            close $wfh;
99            POSIX::dup2($rfh->fileno, 5)
100                or die "dup2 failed:$!";
101            if ($< == 0) {
102                exec qw(share/h2o/kill-on-close -- memcached -u root -l 127.0.0.1 -p), $port;
103            } else {
104                exec qw(share/h2o/kill-on-close -- memcached -l 127.0.0.1 -p), $port;
105            }
106            exit 1;
107        }
108        close $rfh;
109        POSIX::dup($wfh->fileno)
110            or die "dup failed:$!";
111        sleep 1;
112        if (waitpid($pid, WNOHANG) == $pid) {
113            die "failed to launch memcached";
114        }
115        $ENV{MEMCACHED_PORT} = $port;
116    }
117
118    exec $fn;
119    die "failed to exec $fn:$!";
120}
121
122sub exec_mruby_unittest {
123    plan skip_all => 'mruby support is off'
124        unless server_features()->{mruby};
125
126    my $test_dir = path('t/00unit.mruby');
127    my $bin = path(bindir(), 'mruby/host/bin/mruby');
128    unless (-e $bin) {
129        die "unit test: mruby binary $bin does not exist";
130    }
131
132	my $k = 0;
133    $test_dir->visit(sub {
134        my ($path) = @_;
135        return unless $path =~ /\.rb$/;
136
137        my $fn = "$bin $path";
138        my $output = `$fn`;
139
140		# parse mruby test output
141		$output =~ /# Running tests:\n\n([SFE\.]+)\n/
142			or die "cannot parse test output for $path";
143		my ($i, $j) = (0, 0);
144		my @results = map { +{ type => $_, index => ++$i, failed => ($_ eq 'F' || $_ eq 'E') } } split(//, $1);
145		while ($output =~ /\d\) (Skipped|Failure|Error):\n([^\n]+)/g) {
146			my ($type, $detail) = (substr($1, 0, 1), $2);
147			while ($results[$j]->{type} ne $type) { $j++; }
148			$results[$j++]->{detail} = $detail;
149		}
150
151		# print TAP compatible output
152		printf("%s %s\n", $path, '.' x (51 - length($path)));
153		for my $r (@results) {
154			printf("    %s %d - %s\n", $r->{failed} ? 'not ok' : 'ok', $r->{index}, $r->{detail} || '');
155			printf STDERR ("# Error - %s\n", $r->{detail}) if $r->{failed};
156		}
157		printf("    1..%d\n", scalar(@results));
158		printf("%s %d - %s\n", (grep { $_->{failed} } @results) ? 'not ok' : 'ok', ++$k, $path);
159
160    }, +{ recurse => 1 });
161
162	printf("1..%d\n", $k);
163}
164
165sub exec_fuzzer {
166    my $name = shift;
167    my $prog = bindir() . "/h2o-fuzzer-$name";
168
169    plan skip_all => "$prog does not exist"
170        if ! -e $prog;
171
172    is system("$prog -close_fd_mask=3 -runs=1 -max_len=16384 fuzz/$name-corpus < /dev/null"), 0;
173    done_testing;
174}
175
176# spawns a child process and returns a guard object that kills the process when destroyed
177sub spawn_server {
178    my %args = @_;
179    my $ppid = $$;
180    my $pid = fork;
181    die "fork failed:$!"
182        unless defined $pid;
183    if ($pid != 0) {
184        print STDERR "spawning $args{argv}->[0]... ";
185        if ($args{is_ready}) {
186            while (1) {
187                if ($args{is_ready}->()) {
188                    print STDERR "done\n";
189                    last;
190                }
191                if (waitpid($pid, WNOHANG) == $pid) {
192                    die "server failed to start (got $?)\n";
193                }
194                sleep 0.1;
195            }
196        }
197        my $guard = make_guard(sub {
198            return if $$ != $ppid;
199            print STDERR "killing $args{argv}->[0]... ";
200            my $sig = 'TERM';
201          Retry:
202            if (kill $sig, $pid) {
203                my $i = 0;
204                my $sigterm = sig_num('TERM');
205                my $sigkill = sig_num('KILL');
206                my $sigzero = sig_num('ZERO');
207                while (1) {
208                    if (waitpid($pid, WNOHANG) == $pid) {
209                        Test::More::fail "server die with signal $?"
210                            unless $? == $sigterm || $? == $sigkill || $? == $sigzero;
211                        print STDERR "killed (got $?)\n";
212                        last;
213                    }
214                    if ($i++ == 100) {
215                        if ($sig eq 'TERM') {
216                            print STDERR "failed, sending SIGKILL... ";
217                            $sig = 'KILL';
218                            goto Retry;
219                        }
220                        print STDERR "failed, continuing anyways\n";
221                        last;
222                    }
223                    sleep 0.1;
224                }
225            } else {
226                print STDERR "no proc? ($!)\n";
227            }
228        });
229        return wantarray ? ($guard, $pid) : $guard;
230    }
231    # child process
232    exec @{$args{argv}};
233    die "failed to exec $args{argv}->[0]:$!";
234}
235
236sub sig_num {
237    my $name = shift;
238    firstidx { $_ eq $name } split " ", $Config::Config{sig_name};
239}
240
241# returns a hash containing `port`, `tls_port`, `guard`
242sub spawn_h2o {
243    my ($conf) = @_;
244    my @opts;
245    my $max_ssl_version;
246
247    # decide the port numbers
248    my ($port, $tls_port) = empty_ports(2, { host => "0.0.0.0" });
249
250    # setup the configuration file
251    $conf = $conf->($port, $tls_port)
252        if ref $conf eq 'CODE';
253    my $user = $< == 0 ? "root" : "";
254    if (ref $conf eq 'HASH') {
255        @opts = @{$conf->{opts}}
256            if $conf->{opts};
257        $max_ssl_version = $conf->{max_ssl_version} || undef;
258        $user = $conf->{user} if exists $conf->{user};
259        $conf = $conf->{conf};
260    }
261    $conf = <<"EOT";
262$conf
263listen:
264  host: 0.0.0.0
265  port: $port
266listen:
267  host: 0.0.0.0
268  port: $tls_port
269  ssl:
270    key-file: examples/h2o/server.key
271    certificate-file: examples/h2o/server.crt
272    @{[$max_ssl_version ? "max-version: $max_ssl_version" : ""]}
273@{[$user ? "user: $user" : ""]}
274EOT
275
276    my $ret = spawn_h2o_raw($conf, [$port, $tls_port], \@opts);
277    return {
278        %$ret,
279        port => $port,
280        tls_port => $tls_port,
281    };
282}
283
284sub spawn_h2o_raw {
285    my ($conf, $check_ports, $opts) = @_;
286
287    # By default, h2o will launch as many threads as there are CPU cores on the
288    # host, unless 'num-threads' is specified. This results in the process
289    # running out of file descriptors, if the 'nofiles' limit is low and the
290    # host has a large number of CPU cores. So make sure the number of threads
291    # is bound.
292    $conf = "num-threads: 2\n$conf" unless $conf =~ /^num-threads:/m;
293
294    my ($conffh, $conffn) = tempfile(UNLINK => 1);
295    print $conffh $conf;
296
297    # spawn the server
298    my ($guard, $pid) = spawn_server(
299        argv     => [ bindir() . "/h2o", "-c", $conffn, @{$opts || []} ],
300        is_ready => sub {
301            check_port($_) or return for @{ $check_ports || [] };
302            1;
303        },
304    );
305    return {
306        guard    => $guard,
307        pid      => $pid,
308        conf_file => $conffn,
309    };
310}
311
312sub empty_ports {
313    my ($n, @ep_args) = @_;
314    my @ports;
315    while (@ports < $n) {
316        my $t = empty_port(@ep_args);
317        push @ports, $t
318            unless grep { $_ == $t } @ports;
319    }
320    return @ports;
321}
322
323sub create_data_file {
324    my $sz = shift;
325    my ($fh, $fn) = tempfile(UNLINK => 1);
326    print $fh '0' x $sz;
327    close $fh;
328    return $fn;
329}
330
331sub md5_file {
332    my $fn = shift;
333    open my $fh, "<", $fn
334        or die "failed to open file:$fn:$!";
335    local $/;
336    return md5_hex(join '', <$fh>);
337}
338
339sub etag_file {
340    my $fn = shift;
341    my @st = stat $fn
342        or die "failed to stat file:$fn:$!";
343    return sprintf("\"%08x-%zx\"", $st[9], $st[7]);
344}
345
346sub prog_exists {
347    my $prog = shift;
348    system("which $prog > /dev/null 2>&1") == 0;
349}
350
351sub run_prog {
352    my $cmd = shift;
353    my ($tempfh, $tempfn) = tempfile(UNLINK => 1);
354    my $stderr = `$cmd 2>&1 > $tempfn`;
355    my $stdout = do { local $/; <$tempfh> };
356    close $tempfh; # tempfile does not close the file automatically (see perldoc)
357    return ($stderr, $stdout);
358}
359
360sub openssl_can_negotiate {
361    my $openssl_ver = `openssl version`;
362    $openssl_ver =~ /^\S+\s(\d+)\.(\d+)\.(\d+)/
363        or die "cannot parse OpenSSL version: $openssl_ver";
364    $openssl_ver = $1 * 10000 + $2 * 100 + $3;
365    return $openssl_ver >= 10001;
366}
367
368sub curl_supports_http2 {
369    return !! (`curl --version` =~ /^Features:.*\sHTTP2(?:\s|$)/m);
370}
371
372sub run_with_curl {
373    my ($server, $cb) = @_;
374    plan skip_all => "curl not found"
375        unless prog_exists("curl");
376    subtest "http/1" => sub {
377        $cb->("http", $server->{port}, "curl", 257);
378    };
379    subtest "https/1" => sub {
380        my $cmd = "curl --insecure";
381        $cmd .= " --http1.1"
382            if curl_supports_http2();
383        $cb->("https", $server->{tls_port}, $cmd, 257);
384    };
385    subtest "https/2" => sub {
386        plan skip_all => "curl does not support HTTP/2"
387            unless curl_supports_http2();
388        $cb->("https", $server->{tls_port}, "curl --insecure --http2", 512);
389    };
390}
391
392sub h2get_exists {
393    prog_exists(bindir() . "/h2get_bin/h2get");
394}
395
396sub run_with_h2get {
397    my ($server, $script) = @_;
398    plan skip_all => "h2get not found"
399        unless h2get_exists();
400    my $helper_code = <<"EOR";
401class H2
402    def read_loop(timeout)
403        while true
404            f = self.read(timeout)
405            return nil if f == nil
406            puts f.to_s
407            if f.type == "DATA" && f.len > 0
408                self.send_window_update(0, f.len)
409                self.send_window_update(f.stream_id, f.len)
410            end
411            if (f.type == "DATA" || f.type == "HEADERS") && f.is_end_stream
412                return f
413            elsif f.type == "RST_STREAM" || f.type == "GOAWAY"
414                return f
415            end
416        end
417    end
418end
419EOR
420    $script = "$helper_code\n$script";
421    my ($scriptfh, $scriptfn) = tempfile(UNLINK => 1);
422    print $scriptfh $script;
423    close($scriptfh);
424    return run_prog(bindir()."/h2get_bin/h2get $scriptfn 127.0.0.1:$server->{tls_port}");
425}
426
427sub run_with_h2get_simple {
428    my ($server, $script) = @_;
429    my $settings = <<'EOS';
430    h2g = H2.new
431    authority = ARGV[0]
432    host = "https://#{authority}"
433    h2g.connect(host)
434    h2g.send_prefix()
435    h2g.send_settings()
436    i = 0
437    while i < 2 do
438        f = h2g.read(-1)
439        if f.type == "SETTINGS" and (f.flags == ACK) then
440            i += 1
441        elsif f.type == "SETTINGS" then
442            h2g.send_settings_ack()
443            i += 1
444        end
445    end
446EOS
447    run_with_h2get($server, $settings."\n".$script);
448}
449
450sub one_shot_http_upstream {
451    my ($response, $port) = @_;
452    my $listen = IO::Socket::INET->new(
453        LocalHost => '0.0.0.0',
454        LocalPort => $port,
455        Proto     => 'tcp',
456        Listen    => 1,
457        Reuse     => 1,
458    ) or die "failed to listen to 127.0.0.1:$port:$!";
459
460    my $pid = fork;
461    die "fork failed" unless defined $pid;
462    if ($pid != 0) {
463        close $listen;
464        my $guard = make_guard(sub {
465            kill 'KILL', $pid;
466            while (waitpid($pid, WNOHANG) != $pid) {}
467        });
468        return ($port, $guard);
469    }
470
471    while (my $sock = $listen->accept) {
472        $sock->print($response);
473        close $sock;
474    }
475}
476
477sub wait_debugger {
478    my ($pid, $timeout) = @_;
479    $timeout ||= -1;
480
481    print STDERR "waiting debugger for pid $pid ..\n";
482    while ($timeout-- != 0) {
483        my $out = `ps -p $pid -o 'state' | tail -n 1`;
484        if ($out =~ /^(T|.+X).*$/) {
485            print STDERR "debugger attached\n";
486            return 1;
487        }
488        sleep 1;
489    }
490    print STDERR "no debugger attached\n";
491    undef;
492}
493
494sub make_guard {
495    my $code = shift;
496    return Scope::Guard->new(sub {
497        local $?;
498        $code->();
499    });
500}
501
502sub spawn_forked {
503    my ($code) = @_;
504
505    my ($cout, $pin);
506    pipe($pin, $cout);
507    my ($cerr, $pin2);
508    pipe($pin2, $cerr);
509
510    my $pid = fork;
511    if ($pid) {
512        close $cout;
513        close $cerr;
514        my $upstream; $upstream = +{
515            pid => $pid,
516            kill => sub {
517                return unless defined $pid;
518                kill 'KILL', $pid;
519                undef $pid;
520            },
521            guard => make_guard(sub { $upstream->{kill}->() }),
522            stdout => $pin,
523            stderr => $pin2,
524        };
525        return $upstream;
526    }
527    close $pin;
528    close $pin2;
529    open(STDOUT, '>&=', fileno($cout)) or die $!;
530    open(STDERR, '>&=', fileno($cerr)) or die $!;
531
532    $code->();
533    exit;
534}
535
536sub spawn_h2_server {
537    my ($upstream_port, $stream_state_cbs, $stream_frame_cbs) = @_;
538
539    my $upstream = IO::Socket::SSL->new(
540        LocalAddr => '127.0.0.1',
541        LocalPort => $upstream_port,
542        Listen => 1,
543        ReuseAddr => 1,
544        SSL_cert_file => 'examples/h2o/server.crt',
545        SSL_key_file => 'examples/h2o/server.key',
546        SSL_alpn_protocols => ['h2'],
547    ) or die "cannot create socket: $!";
548
549    my $server = spawn_forked(sub {
550        my $conn; $conn = Protocol::HTTP2::Connection->new(Protocol::HTTP2::Constants::SERVER,
551            on_new_peer_stream => sub {
552                my $stream_id = shift;
553                for my $state (keys %{ $stream_state_cbs || +{} }) {
554                    my $cb = $stream_state_cbs->{$state};
555                    $conn->stream_cb($stream_id, $state, sub {
556                        $cb->($conn, $stream_id);
557                    });
558                }
559                for my $type (keys %{ $stream_frame_cbs || +{} }) {
560                    my $cb = $stream_frame_cbs->{$type};
561                    $conn->stream_frame_cb($stream_id, $type, sub {
562                        $cb->($conn, $stream_id, shift);
563                    });
564                }
565            },
566        );
567        $conn->{_state} = +{};
568        $conn->enqueue(Protocol::HTTP2::Constants::SETTINGS, 0, 0, +{});
569        my $sock = $upstream->accept or die "cannot accept socket: $!";
570
571        my $input = '';
572        while (!$conn->{_state}->{closed}) {
573            my $offset = 0;
574            my $buf;
575            my $r = $sock->read($buf, 1);
576            next unless $r;
577            $input .= $buf;
578
579            unless ($conn->preface) {
580                my $len = $conn->preface_decode(\$input, 0);
581                unless (defined($len)) {
582                    die 'invalid preface';
583                }
584                next unless $len;
585                $conn->preface(1);
586                $offset += $len;
587            }
588
589            while (my $len = $conn->frame_decode(\$input, $offset)) {
590                $offset += $len;
591            }
592            substr($input, 0, $offset) = '' if $offset;
593
594            if (my $after_read = delete($conn->{_state}->{after_read})) {
595                $after_read->();
596            }
597
598            while (my $frame = $conn->dequeue) {
599                $sock->write($frame);
600            }
601
602            if (my $after_write = delete($conn->{_state}->{after_write})) {
603                $after_write->();
604            }
605        }
606    });
607
608    close $upstream;
609    return $server;
610}
611
612# usage: see t/90h2olog.t
613package H2ologTracer {
614    use POSIX ":sys_wait_h";
615
616    sub new {
617        my ($class, $opts) = @_;
618        my $h2o_pid = $opts->{pid} or Carp::croak("Missing pid in the opts");
619        my $h2olog_args = $opts->{args} // [];
620        my $h2olog_prog = t::Util::bindir() . "/h2olog";
621
622        my $tempdir = File::Temp::tempdir(CLEANUP => 1);
623        my $output_file = "$tempdir/h2olog.jsonl";
624
625        my $tracer_pid = open my($errfh), "-|", qq{exec $h2olog_prog @{$h2olog_args} -d -p $h2o_pid -w '$output_file' 2>&1};
626        die "failed to spawn $h2olog_prog: $!" unless defined $tracer_pid;
627
628        # wait until h2olog and the trace log becomes ready
629        while (1) {
630            my $errline = <$errfh>;
631            Carp::confess("h2olog[$tracer_pid] died unexpectedly")
632                unless defined $errline;
633            Test::More::diag("h2olog[$tracer_pid]: $errline");
634            last if $errline =~ /Attaching pid=/;
635        }
636
637        open my $fh, "<", $output_file or die "h2olog[$tracer_pid] does not create the output file ($output_file): $!";
638        my $off = 0;
639        my $get_trace = sub {
640            Carp::confess "h2olog[$tracer_pid] is down (got $?)"
641                if waitpid($tracer_pid, WNOHANG) != 0;
642
643            seek $fh, $off, 0 or die "seek failed: $!";
644            read $fh, my $bytes, 65000;
645            $bytes = ''
646                unless defined $bytes;
647            $off += length $bytes;
648            return $bytes;
649        };
650
651        my $guard = t::Util::make_guard(sub {
652            if (waitpid($tracer_pid, WNOHANG) == 0) {
653                Test::More::diag "killing h2olog[$tracer_pid] with SIGTERM";
654                kill("TERM", $tracer_pid)
655                    or warn("failed to kill h2olog[$tracer_pid]: $!");
656            } else {
657                Test::More::diag($_) while <$errfh>; # in case h2olog shows error messages, e.g. BPF program doesn't compile
658                Test::More::diag "h2olog[$tracer_pid] has already exited";
659            }
660        });
661
662        return bless {
663            _guard => $guard,
664            tracer_pid => $tracer_pid,
665            get_trace => $get_trace,
666        }, $class;
667    }
668
669    sub get_trace {
670        my($self) = @_;
671        return $self->{get_trace}->();
672    }
673}
674
675sub find_blackhole_ip {
676    my %ips;
677    my $port = $_[0] || 23;
678    my $blackhole_ip = undef;
679    my $poll = IO::Poll->new();
680    my $start = [ gettimeofday() ];
681
682    foreach my $ip ('10.0.0.1', '192.168.0.1', '172.16.0.1', '240.0.0.1', '192.0.2.0') {
683        my $sock = IO::Socket::INET->new(Blocking => 0, PeerPort => $port, PeerAddr => $ip);
684        $ips{$sock} = $ip;
685        $poll->mask($sock => POLLOUT|POLLIN|POLLERR|POLLHUP);
686    }
687    while (scalar($poll->handles()) > 0 and tv_interval($start) < 2.00) {
688        if ($poll->poll(.1) > 0) {
689            foreach my $sock ($poll->handles(POLLOUT|POLLIN|POLLERR|POLLHUP)) {
690                delete($ips{$sock});
691                $poll->remove($sock);
692                $sock->close()
693            }
694        }
695    }
696    if (scalar($poll->handles()) > 0) {
697        $blackhole_ip = $ips{(keys %ips)[rand(keys %ips)]}
698    }
699    foreach my $sock ($poll->handles()) {
700        $poll->remove($sock);
701        $sock->close();
702    }
703    die unless $poll->handles() == 0;
704    return $blackhole_ip;
705}
706
707sub check_dtrace_availability {
708    run_as_root();
709
710    plan skip_all => 'dtrace support is off'
711        unless server_features()->{dtrace};
712
713    if ($^O eq 'linux') {
714        plan skip_all => 'bpftrace not found'
715            unless prog_exists('bpftrace');
716        # NOTE: the test is likely to depend on https://github.com/iovisor/bpftrace/pull/864
717        plan skip_all => "skipping bpftrace tests (setenv DTRACE_TESTS=1 to run them)"
718            unless $ENV{DTRACE_TESTS};
719    } else {
720        plan skip_all => 'dtrace not found'
721            unless prog_exists('dtrace');
722        plan skip_all => 'unbuffer not found'
723            unless prog_exists('unbuffer');
724    }
725}
726
727sub get_tracer {
728    my $tracer_pid = shift;
729    my $fn = shift;
730    my $read_trace;
731    while (1) {
732        sleep 1;
733        if (open my $fh, "<", $fn) {
734            my $off = 0;
735            $read_trace = sub {
736                seek $fh, $off, 0
737                    or die "seek failed:$!";
738                read $fh, my $bytes, 1048576;
739                $bytes = ''
740                    unless defined $bytes;
741                $off += length $bytes;
742                if ($^O ne 'linux') {
743                    $bytes = join "", map { substr($_, 4) . "\n" } grep /^XXXX/, split /\n/, $bytes;
744                }
745                return $bytes;
746            };
747            last;
748        }
749        die "bpftrace failed to start\n"
750            if waitpid($tracer_pid, WNOHANG) == $tracer_pid;
751    }
752    return $read_trace;
753}
754
755sub run_picotls_client {
756    my($opts) = @_;
757    my $port = $opts->{port}; # required
758    my $host = $opts->{host} // '127.0.0.1';
759    my $path = $opts->{path} // '/';
760    my $cli_opts = $opts->{opts} // '';
761
762    my $cli = bindir() . "/picotls/cli";
763
764    my $tempdir = tempdir();
765    my $cmd = "exec $cli $cli_opts $host $port > $tempdir/resp.txt 2>&1";
766    diag $cmd;
767    open my $fh, "|-", $cmd
768        or die "failed to invoke command:$cmd:$!";
769    autoflush $fh 1;
770    print $fh <<"EOT";
771GET $path HTTP/1.1\r
772Host: $host:$port\r
773Connection: close\r
774\r
775EOT
776    sleep 1;
777    close $fh;
778
779    open $fh, "<", "$tempdir/resp.txt"
780        or die "failed to open file:$tempdir/resp.txt:$!";
781    my $resp = do { local $/; <$fh> };
782    return $resp;
783}
784
785sub spawn_dns_server {
786    my ($dns_port, $zone_rrs, $delays) = @_;
787
788    my $server = spawn_forked(sub {
789            my $ns = Net::DNS::Nameserver->new(
790                LocalPort    => $dns_port,
791                ReplyHandler => sub {
792                    my ($qname, $qclass, $qtype, $peerhost, $query, $conn) = @_;
793                    my ($rcode, @ans, @auth, @add);
794
795                    foreach (@$zone_rrs) {
796                        my $rr = Net::DNS::RR->new($_);
797                        if ($rr->owner eq $qname && $rr->class eq $qclass && $rr->type eq $qtype) {
798                            push @ans, $rr;
799                        }
800                    }
801
802                    if (!@ans) {
803                        $rcode = "NXDOMAIN";
804                    } else {
805                        $rcode = "NOERROR";
806                    }
807                    # mark the answer as authoritative (by setting the 'aa' flag)
808                    my $headermask = {aa => 1};
809                    my $optionmask = {};
810                    if ($delays && $delays->{$qtype} > 0) {
811                        sleep($delays->{$qtype});
812                    }
813                    @ans = shuffle(@ans);
814                    return ($rcode, \@ans, \@auth, \@add, $headermask, $optionmask);
815                },
816                Verbose      => 0
817            ) || die "couldn't create nameserver object\n";
818            $ns->main_loop;
819        });
820    return $server;
821}
822
8231;
824