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