1# $OpenBSD: funcs.pl,v 1.26 2024/06/14 15:12:57 bluhm Exp $ 2 3# Copyright (c) 2010-2021 Alexander Bluhm <bluhm@openbsd.org> 4# 5# Permission to use, copy, modify, and distribute this software for any 6# purpose with or without fee is hereby granted, provided that the above 7# copyright notice and this permission notice appear in all copies. 8# 9# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 17use strict; 18use warnings; 19use Errno; 20use Digest::MD5; 21use Socket; 22use Socket6; 23use IO::Socket; 24use IO::Socket::IP; 25 26sub find_ports { 27 my %args = @_; 28 my $num = delete $args{num} // 1; 29 my $domain = delete $args{domain} // AF_INET; 30 my $addr = delete $args{addr} // "127.0.0.1"; 31 32 my @sockets = (1..$num); 33 foreach my $s (@sockets) { 34 $s = IO::Socket::IP->new( 35 Proto => "tcp", 36 Family => $domain, 37 $addr ? (LocalAddr => $addr) : (), 38 ) or die "find_ports: create and bind socket failed: $!"; 39 } 40 my @ports = map { $_->sockport() } @sockets; 41 42 return @ports; 43} 44 45######################################################################## 46# Client funcs 47######################################################################## 48 49sub write_syswrite { 50 my $self = shift; 51 my $buf = shift; 52 53 IO::Handle::flush(\*STDOUT); 54 my $size = length($buf); 55 my $len = 0; 56 while ($len < $size) { 57 my $n = syswrite(STDOUT, $buf, $size, $len); 58 if (!defined($n)) { 59 $!{EWOULDBLOCK} 60 or die ref($self), " syswrite failed: $!"; 61 print STDERR "blocked write at $len of $size: $!\n"; 62 next; 63 } 64 if ($len + $n != $size) { 65 print STDERR "short write $n at $len of $size\n"; 66 } 67 $len += $n; 68 } 69 return $len; 70} 71 72sub write_block { 73 my $self = shift; 74 my $len = shift; 75 76 my $data; 77 my $outb = 0; 78 my $blocks = int($len / 1000); 79 my $rest = $len % 1000; 80 81 for (my $i = 1; $i <= 100 ; $i++) { 82 $data .= "012345678\n"; 83 } 84 85 my $opct = 0; 86 for (my $i = 1; $i <= $blocks; $i++) { 87 $outb += write_syswrite($self, $data); 88 my $pct = ($outb / $len) * 100.0; 89 if ($pct >= $opct + 1) { 90 printf(STDERR "%.2f%% $outb/$len\n", $pct); 91 $opct = $pct; 92 } 93 } 94 95 if ($rest>0) { 96 for (my $i = 1; $i < $rest-1 ; $i++) { 97 $outb += write_syswrite($self, 'r'); 98 my $pct = ($outb / $len) * 100.0; 99 if ($pct >= $opct + 1) { 100 printf(STDERR "%.2f%% $outb/$len\n", $pct); 101 $opct = $pct; 102 } 103 } 104 } 105 $outb += write_syswrite($self, "\n\n"); 106 IO::Handle::flush(\*STDOUT); 107 print STDERR "LEN: ", $outb, "\n"; 108} 109 110sub write_char { 111 my $self = shift; 112 my $len = shift // $self->{len} // 251; 113 my $sleep = $self->{sleep}; 114 115 if ($self->{fast}) { 116 write_block($self, $len); 117 return; 118 } 119 120 my $ctx = Digest::MD5->new(); 121 my $char = '0'; 122 for (my $i = 1; $i < $len; $i++) { 123 $ctx->add($char); 124 print $char 125 or die ref($self), " print failed: $!"; 126 if ($char =~ /9/) { $char = 'A' } 127 elsif ($char =~ /Z/) { $char = 'a' } 128 elsif ($char =~ /z/) { $char = "\n" } 129 elsif ($char =~ /\n/) { print STDERR "."; $char = '0' } 130 else { $char++ } 131 if ($self->{sleep}) { 132 IO::Handle::flush(\*STDOUT); 133 sleep $self->{sleep}; 134 } 135 } 136 if ($len) { 137 $char = "\n"; 138 $ctx->add($char); 139 print $char 140 or die ref($self), " print failed: $!"; 141 print STDERR ".\n"; 142 } 143 IO::Handle::flush(\*STDOUT); 144 145 print STDERR "LEN: ", $len, "\n"; 146 print STDERR "MD5: ", $ctx->hexdigest, "\n"; 147} 148 149sub http_client { 150 my $self = shift; 151 152 unless ($self->{lengths}) { 153 # only a single http request 154 my $len = shift // $self->{len} // 251; 155 my $cookie = $self->{cookie}; 156 http_request($self, $len, "1.0", $cookie); 157 http_response($self, $len); 158 return; 159 } 160 161 $self->{http_vers} ||= ["1.1", "1.0"]; 162 my $vers = $self->{http_vers}[0]; 163 my @lengths = @{$self->{redo}{lengths} || $self->{lengths}}; 164 my @cookies = @{$self->{redo}{cookies} || $self->{cookies} || []}; 165 while (defined (my $len = shift @lengths)) { 166 my $cookie = shift @cookies || $self->{cookie}; 167 eval { 168 http_request($self, $len, $vers, $cookie); 169 http_response($self, $len); 170 }; 171 warn $@ if $@; 172 if (@lengths && ($@ || $vers eq "1.0")) { 173 # reconnect and redo the outstanding requests 174 $self->{redo} = { 175 lengths => \@lengths, 176 cookies => \@cookies, 177 }; 178 return; 179 } 180 } 181 delete $self->{redo}; 182 shift @{$self->{http_vers}}; 183 if (@{$self->{http_vers}}) { 184 # run the tests again with other persistence 185 $self->{redo} = { 186 lengths => [@{$self->{lengths}}], 187 cookies => [@{$self->{cookies} || []}], 188 }; 189 } 190} 191 192sub http_request { 193 my ($self, $len, $vers, $cookie) = @_; 194 my $method = $self->{method} || "GET"; 195 my %header = %{$self->{header} || {}}; 196 197 # encode the requested length or chunks into the url 198 my $path = ref($len) eq 'ARRAY' ? join("/", @$len) : $len; 199 # overwrite path with custom path 200 if (defined($self->{path})) { 201 $path = $self->{path}; 202 } 203 my @request = ("$method /$path HTTP/$vers"); 204 push @request, "Host: foo.bar" unless defined $header{Host}; 205 if ($vers eq "1.1" && $method eq "PUT") { 206 if (ref($len) eq 'ARRAY') { 207 push @request, "Transfer-Encoding: chunked" 208 if !defined $header{'Transfer-Encoding'}; 209 } else { 210 push @request, "Content-Length: $len" 211 if !defined $header{'Content-Length'}; 212 } 213 } 214 foreach my $key (sort keys %header) { 215 my $val = $header{$key}; 216 if (ref($val) eq 'ARRAY') { 217 push @request, "$key: $_" 218 foreach @{$val}; 219 } else { 220 push @request, "$key: $val"; 221 } 222 } 223 push @request, "Cookie: $cookie" if $cookie; 224 push @request, ""; 225 print STDERR map { ">>> $_\n" } @request; 226 print map { "$_\r\n" } @request; 227 if ($method eq "PUT") { 228 if (ref($len) eq 'ARRAY') { 229 if ($vers eq "1.1") { 230 write_chunked($self, @$len); 231 } else { 232 write_char($self, $_) foreach (@$len); 233 } 234 } else { 235 write_char($self, $len); 236 } 237 } 238 IO::Handle::flush(\*STDOUT); 239 # XXX client shutdown seems to be broken in relayd 240 #shutdown(\*STDOUT, SHUT_WR) 241 # or die ref($self), " shutdown write failed: $!" 242 # if $vers ne "1.1"; 243} 244 245sub http_response { 246 my ($self, $len) = @_; 247 my $method = $self->{method} || "GET"; 248 249 my $vers; 250 my $chunked = 0; 251 { 252 local $/ = "\r\n"; 253 local $_ = <STDIN>; 254 defined 255 or die ref($self), " missing http $len response"; 256 chomp; 257 print STDERR "<<< $_\n"; 258 m{^HTTP/(\d\.\d) 200 OK$} 259 or die ref($self), " http response not ok" 260 unless $self->{httpnok}; 261 $vers = $1; 262 while (<STDIN>) { 263 chomp; 264 print STDERR "<<< $_\n"; 265 last if /^$/; 266 if (/^Content-Length: (.*)/) { 267 if ($self->{httpnok}) { 268 $len = $1; 269 } else { 270 $1 == $len or die ref($self), 271 " bad content length $1"; 272 } 273 } 274 if (/^Transfer-Encoding: chunked$/) { 275 $chunked = 1; 276 } 277 } 278 } 279 if ($method ne 'HEAD') { 280 if ($chunked) { 281 read_chunked($self); 282 } else { 283 undef $len unless defined($vers) && $vers eq "1.1"; 284 read_char($self, $len) 285 if $method eq "GET"; 286 } 287 } 288} 289 290sub read_chunked { 291 my $self = shift; 292 293 for (;;) { 294 my $len; 295 { 296 local $/ = "\r\n"; 297 local $_ = <STDIN>; 298 defined or die ref($self), " missing chunk size"; 299 chomp; 300 print STDERR "<<< $_\n"; 301 /^[[:xdigit:]]+$/ 302 or die ref($self), " chunk size not hex: $_"; 303 $len = hex; 304 } 305 last unless $len > 0; 306 read_char($self, $len); 307 { 308 local $/ = "\r\n"; 309 local $_ = <STDIN>; 310 defined or die ref($self), " missing chunk data end"; 311 chomp; 312 print STDERR "<<< $_\n"; 313 /^$/ or die ref($self), " no chunk data end: $_"; 314 } 315 } 316 { 317 local $/ = "\r\n"; 318 while (<STDIN>) { 319 chomp; 320 print STDERR "<<< $_\n"; 321 last if /^$/; 322 } 323 defined or die ref($self), " missing chunk trailer"; 324 } 325} 326 327sub errignore { 328 $SIG{PIPE} = 'IGNORE'; 329 $SIG{__DIE__} = sub { 330 die @_ if $^S; 331 warn "Error ignored"; 332 warn @_; 333 IO::Handle::flush(\*STDERR); 334 POSIX::_exit(0); 335 }; 336} 337 338######################################################################## 339# Common funcs 340######################################################################## 341 342sub read_char { 343 my $self = shift; 344 my $max = shift // $self->{max}; 345 346 if ($self->{fast}) { 347 read_block($self, $max); 348 return; 349 } 350 351 my $ctx = Digest::MD5->new(); 352 my $len = 0; 353 if (defined($max) && $max == 0) { 354 print STDERR "Max\n"; 355 } else { 356 while (<STDIN>) { 357 $len += length($_); 358 $ctx->add($_); 359 print STDERR "."; 360 if (defined($max) && $len >= $max) { 361 print STDERR "\nMax"; 362 last; 363 } 364 } 365 print STDERR "\n"; 366 } 367 368 print STDERR "LEN: ", $len, "\n"; 369 print STDERR "MD5: ", $ctx->hexdigest, "\n"; 370} 371 372sub read_block { 373 my $self = shift; 374 my $max = shift // $self->{max}; 375 376 my $opct = 0; 377 my $ctx = Digest::MD5->new(); 378 my $len = 0; 379 for (;;) { 380 if (defined($max) && $len >= $max) { 381 print STDERR "Max\n"; 382 last; 383 } 384 my $rlen = POSIX::BUFSIZ; 385 if (defined($max) && $rlen > $max - $len) { 386 $rlen = $max - $len; 387 } 388 defined(my $n = read(STDIN, my $buf, $rlen)) 389 or die ref($self), " read failed: $!"; 390 $n or last; 391 $len += $n; 392 $ctx->add($buf); 393 my $pct = ($len / $max) * 100.0; 394 if ($pct >= $opct + 1) { 395 printf(STDERR "%.2f%% $len/$max\n", $pct); 396 $opct = $pct; 397 } 398 } 399 400 print STDERR "LEN: ", $len, "\n"; 401 print STDERR "MD5: ", $ctx->hexdigest, "\n"; 402} 403 404######################################################################## 405# Server funcs 406######################################################################## 407 408sub http_server { 409 my $self = shift; 410 my %header = %{$self->{header} || { Server => "Perl/".$^V }}; 411 my $cookie = $self->{cookie} || ""; 412 413 my($method, $url, $vers); 414 do { 415 my $len; 416 { 417 local $/ = "\r\n"; 418 local $_ = <STDIN>; 419 return unless defined $_; 420 chomp; 421 print STDERR "<<< $_\n"; 422 ($method, $url, $vers) = m{^(\w+) (.*) HTTP/(1\.[01])$} 423 or die ref($self), " http request not ok"; 424 $method =~ /^(GET|HEAD|PUT)$/ 425 or die ref($self), " unknown method: $method"; 426 ($len, my @chunks) = $url =~ /(\d+)/g; 427 $len = [ $len, @chunks ] if @chunks; 428 while (<STDIN>) { 429 chomp; 430 print STDERR "<<< $_\n"; 431 last if /^$/; 432 if ($method eq "PUT" && 433 /^Content-Length: (.*)/) { 434 $1 == $len or die ref($self), 435 " bad content length $1"; 436 } 437 $cookie ||= $1 if /^Cookie: (.*)/; 438 } 439 } 440 if ($method eq "PUT" ) { 441 if (ref($len) eq 'ARRAY') { 442 read_chunked($self); 443 } else { 444 read_char($self, $len); 445 } 446 } 447 448 my @response = ("HTTP/$vers 200 OK"); 449 $len = defined($len) ? $len : scalar(split /|/,$url); 450 if ($vers eq "1.1" && $method =~ /^(GET|HEAD)$/) { 451 if (ref($len) eq 'ARRAY') { 452 push @response, "Transfer-Encoding: chunked"; 453 } else { 454 push @response, "Content-Length: $len"; 455 } 456 } 457 foreach my $key (sort keys %header) { 458 my $val = $header{$key}; 459 if (ref($val) eq 'ARRAY') { 460 push @response, "$key: $_" 461 foreach @{$val}; 462 } else { 463 push @response, "$key: $val"; 464 } 465 } 466 push @response, "Set-Cookie: $cookie" if $cookie; 467 push @response, ""; 468 469 print STDERR map { ">>> $_\n" } @response; 470 print map { "$_\r\n" } @response; 471 472 if ($method eq "GET") { 473 if (ref($len) eq 'ARRAY') { 474 if ($vers eq "1.1") { 475 write_chunked($self, @$len); 476 } else { 477 write_char($self, $_) foreach (@$len); 478 } 479 } else { 480 write_char($self, $len); 481 } 482 } 483 IO::Handle::flush(\*STDOUT); 484 } while ($vers eq "1.1"); 485 $self->{redo}-- if $self->{redo}; 486} 487 488sub write_chunked { 489 my $self = shift; 490 my @chunks = @_; 491 492 foreach my $len (@chunks) { 493 printf STDERR ">>> %x\n", $len; 494 printf "%x\r\n", $len; 495 write_char($self, $len); 496 printf STDERR ">>> \n"; 497 print "\r\n"; 498 } 499 my @trailer = ("0", "X-Chunk-Trailer: @chunks", ""); 500 print STDERR map { ">>> $_\n" } @trailer; 501 print map { "$_\r\n" } @trailer; 502} 503 504######################################################################## 505# Script funcs 506######################################################################## 507 508sub check_logs { 509 my ($c, $r, $s, %args) = @_; 510 511 return if $args{nocheck}; 512 513 check_len($c, $r, $s, %args); 514 check_md5($c, $r, $s, %args); 515 check_loggrep($c, $r, $s, %args); 516 $r->loggrep("lost child") 517 and die "relayd lost child"; 518} 519 520sub array_eq { 521 my ($a, $b) = @_; 522 return if @$a != @$b; 523 for (my $i = 0; $i < @$a; $i++) { 524 return if $$a[$i] ne $$b[$i]; 525 } 526 return 1; 527} 528 529sub check_len { 530 my ($c, $r, $s, %args) = @_; 531 532 $args{len} ||= 251 unless $args{lengths}; 533 534 my (@clen, @slen); 535 @clen = $c->loggrep(qr/^LEN: /) or die "no client len" 536 unless $args{client}{nocheck}; 537 @slen = $s->loggrep(qr/^LEN: /) or die "no server len" 538 unless $args{server}{nocheck}; 539 !@clen || !@slen || array_eq \@clen, \@slen 540 or die "client: @clen", "server: @slen", "len mismatch"; 541 !defined($args{len}) || !$clen[0] || $clen[0] eq "LEN: $args{len}\n" 542 or die "client: $clen[0]", "len $args{len} expected"; 543 !defined($args{len}) || !$slen[0] || $slen[0] eq "LEN: $args{len}\n" 544 or die "server: $slen[0]", "len $args{len} expected"; 545 my @lengths = map { ref eq 'ARRAY' ? @$_ : $_ } 546 @{$args{lengths} || []}; 547 foreach my $len (@lengths) { 548 unless ($args{client}{nocheck}) { 549 my $clen = shift @clen; 550 $clen eq "LEN: $len\n" 551 or die "client: $clen", "len $len expected"; 552 } 553 unless ($args{server}{nocheck}) { 554 my $slen = shift @slen; 555 $slen eq "LEN: $len\n" 556 or die "server: $slen", "len $len expected"; 557 } 558 } 559} 560 561sub check_md5 { 562 my ($c, $r, $s, %args) = @_; 563 564 my (@cmd5, @smd5); 565 @cmd5 = $c->loggrep(qr/^MD5: /) unless $args{client}{nocheck}; 566 @smd5 = $s->loggrep(qr/^MD5: /) unless $args{server}{nocheck}; 567 !@cmd5 || !@smd5 || $cmd5[0] eq $smd5[0] 568 or die "client: $cmd5[0]", "server: $smd5[0]", "md5 mismatch"; 569 570 my @md5 = ref($args{md5}) eq 'ARRAY' ? @{$args{md5}} : $args{md5} || () 571 or return; 572 foreach my $md5 (@md5) { 573 unless ($args{client}{nocheck}) { 574 my $cmd5 = shift @cmd5 575 or die "too few md5 in client log"; 576 $cmd5 =~ /^MD5: ($md5)$/ 577 or die "client: $cmd5", "md5 $md5 expected"; 578 } 579 unless ($args{server}{nocheck}) { 580 my $smd5 = shift @smd5 581 or die "too few md5 in server log"; 582 $smd5 =~ /^MD5: ($md5)$/ 583 or die "server: $smd5", "md5 $md5 expected"; 584 } 585 } 586 @cmd5 && ref($args{md5}) eq 'ARRAY' 587 and die "too many md5 in client log"; 588 @smd5 && ref($args{md5}) eq 'ARRAY' 589 and die "too many md5 in server log"; 590} 591 592sub check_loggrep { 593 my ($c, $r, $s, %args) = @_; 594 595 my %name2proc = (client => $c, relayd => $r, server => $s); 596 foreach my $name (qw(client relayd server)) { 597 my $p = $name2proc{$name} or next; 598 my $pattern = $args{$name}{loggrep} or next; 599 $pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY'; 600 foreach my $pat (@$pattern) { 601 if (ref($pat) eq 'HASH') { 602 while (my($re, $num) = each %$pat) { 603 my @matches = $p->loggrep($re); 604 @matches == $num 605 or die "$name matches '@matches': ", 606 "'$re' => $num"; 607 } 608 } else { 609 $p->loggrep($pat) 610 or die "$name log missing pattern: '$pat'"; 611 } 612 } 613 } 614} 615 6161; 617