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