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