xref: /openbsd/regress/usr.sbin/httpd/tests/funcs.pl (revision 508def2a) 
1#	$OpenBSD: funcs.pl,v 1.10 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 POSIX;
22use Socket;
23use Socket6;
24use IO::Socket;
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		    Domain => $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
45sub path_md5 {
46	my $name = shift;
47	my $val = `cat md5-$name`;
48}
49
50########################################################################
51# Client funcs
52########################################################################
53
54sub write_char {
55	my $self = shift;
56	my $len = shift // $self->{len} // 512;
57	my $sleep = $self->{sleep};
58
59	my $ctx = Digest::MD5->new();
60	my $char = '0';
61	for (my $i = 1; $i < $len; $i++) {
62		$ctx->add($char);
63		print $char
64		    or die ref($self), " print failed: $!";
65		if    ($char =~ /9/)  { $char = 'A' }
66		elsif ($char =~ /Z/)  { $char = 'a' }
67		elsif ($char =~ /z/)  { $char = "\n" }
68		elsif ($char =~ /\n/) { print STDERR "."; $char = '0' }
69		else                  { $char++ }
70		if ($self->{sleep}) {
71			IO::Handle::flush(\*STDOUT);
72			sleep $self->{sleep};
73		}
74	}
75	if ($len) {
76		$char = "\n";
77		$ctx->add($char);
78		print $char
79		    or die ref($self), " print failed: $!";
80		print STDERR ".\n";
81	}
82	IO::Handle::flush(\*STDOUT);
83
84	print STDERR "LEN: ", $len, "\n";
85	print STDERR "MD5: ", $ctx->hexdigest, "\n";
86}
87
88sub http_client {
89	my $self = shift;
90
91	unless ($self->{lengths}) {
92		# only a single http request
93		my $len = shift // $self->{len} // 512;
94		my $cookie = $self->{cookie};
95		http_request($self, $len, "1.0", $cookie);
96		http_response($self, $len);
97		return;
98	}
99
100	$self->{http_vers} ||= ["1.1", "1.0"];
101	my $vers = $self->{http_vers}[0];
102	my @lengths = @{$self->{redo}{lengths} || $self->{lengths}};
103	my @cookies = @{$self->{redo}{cookies} || $self->{cookies} || []};
104	while (defined (my $len = shift @lengths)) {
105		my $cookie = shift @cookies || $self->{cookie};
106		eval {
107			http_request($self, $len, $vers, $cookie);
108			http_response($self, $len);
109		};
110		warn $@ if $@;
111		if (@lengths && ($@ || $vers eq "1.0")) {
112			# reconnect and redo the outstanding requests
113			$self->{redo} = {
114			    lengths => \@lengths,
115			    cookies => \@cookies,
116			};
117			return;
118		}
119	}
120	delete $self->{redo};
121	shift @{$self->{http_vers}};
122	if (@{$self->{http_vers}}) {
123		# run the tests again with other persistence
124		$self->{redo} = {
125		    lengths => [@{$self->{lengths}}],
126		    cookies => [@{$self->{cookies} || []}],
127		};
128	}
129}
130
131sub http_request {
132	my ($self, $len, $vers, $cookie) = @_;
133	my $method = $self->{method} || "GET";
134	my %header = %{$self->{header} || {}};
135
136	# encode the requested length or chunks into the url
137	my $path = ref($len) eq 'ARRAY' ? join("/", @$len) : $len;
138	# overwrite path with custom path
139	if (defined($self->{path})) {
140		$path = $self->{path};
141	}
142	my @request = ("$method /$path HTTP/$vers");
143	push @request, "Host: foo.bar" unless defined $header{Host};
144	if ($vers eq "1.1" && $method eq "PUT") {
145		if (ref($len) eq 'ARRAY') {
146			push @request, "Transfer-Encoding: chunked"
147			    if !defined $header{'Transfer-Encoding'};
148		} else {
149			push @request, "Content-Length: $len"
150			    if !defined $header{'Content-Length'};
151		}
152	}
153	foreach my $key (sort keys %header) {
154		my $val = $header{$key};
155		if (ref($val) eq 'ARRAY') {
156			push @request, "$key: $_"
157			    foreach @{$val};
158		} else {
159			push @request, "$key: $val";
160		}
161	}
162	push @request, "Cookie: $cookie" if $cookie;
163	push @request, "";
164	print STDERR map { ">>> $_\n" } @request;
165	print map { "$_\r\n" } @request;
166	if ($method eq "PUT") {
167		if (ref($len) eq 'ARRAY') {
168			if ($vers eq "1.1") {
169				write_chunked($self, @$len);
170			} else {
171				write_char($self, $_) foreach (@$len);
172			}
173		} else {
174			write_char($self, $len);
175		}
176	}
177	IO::Handle::flush(\*STDOUT);
178	# XXX client shutdown seems to be broken in httpd
179	#shutdown(\*STDOUT, SHUT_WR)
180	#    or die ref($self), " shutdown write failed: $!"
181	#    if $vers ne "1.1";
182}
183
184sub http_response {
185	my ($self, $len) = @_;
186	my $method = $self->{method} || "GET";
187	my $code = $self->{code} || "200 OK";
188
189	my $vers;
190	my $chunked = 0;
191	my $multipart = 0;
192	my $boundary;
193	{
194		local $/ = "\r\n";
195		local $_ = <STDIN>;
196		defined
197		    or die ref($self), " missing http $len response";
198		chomp;
199		print STDERR "<<< $_\n";
200		m{^HTTP/(\d\.\d) $code$}
201		    or die ref($self), " http response not $code"
202		    unless $self->{httpnok};
203		$vers = $1;
204		while (<STDIN>) {
205			chomp;
206			print STDERR "<<< $_\n";
207			last if /^$/;
208			if (/^Content-Length: (.*)/) {
209				if ($self->{httpnok} or $self->{multipart}) {
210					$len = $1;
211				} else {
212					$1 == $len or die ref($self),
213					    " bad content length $1";
214				}
215			}
216			if (/^Transfer-Encoding: chunked$/) {
217				$chunked = 1;
218			}
219			if (/^Content-Type: multipart\/byteranges; boundary=(.*)$/) {
220				$multipart = 1;
221				$boundary = $1;
222			}
223		}
224	}
225	die ref($self), " no multipart response"
226	    if ($self->{multipart} && $multipart == 0);
227
228	if ($multipart) {
229		read_multipart($self, $boundary);
230	} elsif ($chunked) {
231		read_chunked($self);
232	} else {
233		read_char($self, $len)
234		    if $method eq "GET";
235	}
236}
237
238sub read_chunked {
239	my $self = shift;
240
241	for (;;) {
242		my $len;
243		{
244			local $/ = "\r\n";
245			local $_ = <STDIN>;
246			defined or die ref($self), " missing chunk size";
247			chomp;
248			print STDERR "<<< $_\n";
249			/^[[:xdigit:]]+$/
250			    or die ref($self), " chunk size not hex: $_";
251			$len = hex;
252		}
253		last unless $len > 0;
254		read_char($self, $len);
255		{
256			local $/ = "\r\n";
257			local $_ = <STDIN>;
258			defined or die ref($self), " missing chunk data end";
259			chomp;
260			print STDERR "<<< $_\n";
261			/^$/ or die ref($self), " no chunk data end: $_";
262		}
263	}
264	{
265		local $/ = "\r\n";
266		while (<STDIN>) {
267			chomp;
268			print STDERR "<<< $_\n";
269			last if /^$/;
270		}
271		defined or die ref($self), " missing chunk trailer";
272	}
273}
274
275sub read_multipart {
276	my $self = shift;
277	my $boundary = shift;
278	my $ctx = Digest::MD5->new();
279	my $len = 0;
280
281	for (;;) {
282		my $part = 0;
283		{
284			local $/ = "\r\n";
285			local $_ = <STDIN>;
286			local $_ = <STDIN>;
287			defined or die ref($self), " missing boundary";
288			chomp;
289			print STDERR "<<< $_\n";
290			/^--$boundary(--)?$/
291			    or die ref($self), " boundary not found: $_";
292			if (not $1) {
293				while (<STDIN>) {
294					chomp;
295					if (/^Content-Length: (.*)/) {
296						$part = $1;
297					}
298					if (/^Content-Range: bytes (\d+)-(\d+)\/(\d+)$/) {
299						$part = $2 - $1 + 1;
300					}
301					print STDERR "<<< $_\n";
302					last if /^$/;
303				}
304			}
305		}
306		last unless $part > 0;
307
308		$len += read_part($self, $ctx, $part);
309	}
310
311	print STDERR "LEN: ", $len, "\n";
312	print STDERR "MD5: ", $ctx->hexdigest, "\n";
313}
314
315sub errignore {
316	$SIG{PIPE} = 'IGNORE';
317	$SIG{__DIE__} = sub {
318		die @_ if $^S;
319		warn "Error ignored";
320		warn @_;
321		IO::Handle::flush(\*STDERR);
322		POSIX::_exit(0);
323	};
324}
325
326########################################################################
327# Common funcs
328########################################################################
329
330sub read_char {
331	my $self = shift;
332	my $max = shift // $self->{max};
333
334	my $ctx = Digest::MD5->new();
335	my $len = read_part($self, $ctx, $max);
336
337	print STDERR "LEN: ", $len, "\n";
338	print STDERR "MD5: ", $ctx->hexdigest, "\n";
339}
340
341sub read_part {
342	my $self = shift;
343	my ($ctx, $max) = @_;
344
345	my $opct = 0;
346	my $len = 0;
347	for (;;) {
348		if (defined($max) && $len >= $max) {
349			print STDERR "Max\n";
350			last;
351		}
352		my $rlen = POSIX::BUFSIZ;
353		if (defined($max) && $rlen > $max - $len) {
354			$rlen = $max - $len;
355		}
356		defined(my $n = read(STDIN, my $buf, $rlen))
357		    or die ref($self), " read failed: $!";
358		$n or last;
359		$len += $n;
360		$ctx->add($buf);
361		my $pct = ($len / $max) * 100.0;
362		if ($pct >= $opct + 1) {
363			printf(STDERR "%.2f%% $len/$max\n", $pct);
364			$opct = $pct;
365		}
366	}
367	return $len;
368}
369
370sub write_chunked {
371	my $self = shift;
372	my @chunks = @_;
373
374	foreach my $len (@chunks) {
375		printf STDERR ">>> %x\n", $len;
376		printf "%x\r\n", $len;
377		write_char($self, $len);
378		printf STDERR ">>> \n";
379		print "\r\n";
380	}
381	my @trailer = ("0", "X-Chunk-Trailer: @chunks", "");
382	print STDERR map { ">>> $_\n" } @trailer;
383	print map { "$_\r\n" } @trailer;
384}
385
386########################################################################
387# Script funcs
388########################################################################
389
390sub check_logs {
391	my ($c, $r, %args) = @_;
392
393	return if $args{nocheck};
394
395	check_len($c, $r, %args);
396	check_md5($c, $r, %args);
397	check_loggrep($c, $r, %args);
398	$r->loggrep("lost child")
399	    and die "httpd lost child";
400}
401
402sub check_len {
403	my ($c, $r, %args) = @_;
404
405	$args{len} ||= 512 unless $args{lengths};
406
407	my @clen;
408	@clen = $c->loggrep(qr/^LEN: /) or die "no client len"
409	    unless $args{client}{nocheck};
410#	!@clen
411#	    or die "client: @clen", "len mismatch";
412	!defined($args{len}) || !$clen[0] || $clen[0] eq "LEN: $args{len}\n"
413	    or die "client: $clen[0]", "len $args{len} expected";
414	my @lengths = map { ref eq 'ARRAY' ? @$_ : $_ }
415	    @{$args{lengths} || []};
416	foreach my $len (@lengths) {
417		unless ($args{client}{nocheck}) {
418			my $clen = shift @clen;
419			$clen eq "LEN: $len\n"
420			    or die "client: $clen", "len $len expected";
421		}
422	}
423}
424
425sub check_md5 {
426	my ($c, $r, %args) = @_;
427
428	my @cmd5;
429	@cmd5 = $c->loggrep(qr/^MD5: /) unless $args{client}{nocheck};
430	my @md5 = ref($args{md5}) eq 'ARRAY' ? @{$args{md5}} : $args{md5} || ()
431	    or return;
432	foreach my $md5 (@md5) {
433		unless ($args{client}{nocheck}) {
434			my $cmd5 = shift @cmd5
435			    or die "too few md5 in client log";
436			$cmd5 =~ /^MD5: ($md5)$/
437			    or die "client: $cmd5", "md5 $md5 expected";
438		}
439	}
440	@cmd5 && ref($args{md5}) eq 'ARRAY'
441	    and die "too many md5 in client log";
442}
443
444sub check_loggrep {
445	my ($c, $r, %args) = @_;
446
447	my %name2proc = (client => $c, httpd => $r);
448	foreach my $name (qw(client httpd)) {
449		my $p = $name2proc{$name} or next;
450		my $pattern = $args{$name}{loggrep} or next;
451		$pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY';
452		foreach my $pat (@$pattern) {
453			if (ref($pat) eq 'HASH') {
454				while (my($re, $num) = each %$pat) {
455					my @matches = $p->loggrep($re);
456					@matches == $num
457					    or die "$name matches '@matches': ",
458					    "'$re' => $num";
459				}
460			} else {
461				$p->loggrep($pat)
462				    or die "$name log missing pattern: '$pat'";
463			}
464		}
465	}
466}
467
4681;
469