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