1#! /usr/bin/perl -w
2
3package LightyTest;
4use strict;
5use IO::Socket;
6use Test::More;
7use Socket;
8use Cwd 'abs_path';
9use POSIX qw(:sys_wait_h dup2);
10use Errno qw(EADDRINUSE);
11
12sub mtime {
13	my $file = shift;
14	my @stat = stat $file;
15	return @stat ? $stat[9] : 0;
16}
17sub new {
18	my $class = shift;
19	my $self = {};
20	my $lpath;
21
22	$self->{CONFIGFILE} = 'lighttpd.conf';
23
24	$lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'} : '..');
25	$self->{BASEDIR} = abs_path($lpath);
26
27	$lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'}."/tests/" : '.');
28	$self->{TESTDIR} = abs_path($lpath);
29
30	$lpath = (defined $ENV{'srcdir'} ? $ENV{'srcdir'} : '.');
31	$self->{SRCDIR} = abs_path($lpath);
32
33
34	if (mtime($self->{BASEDIR}.'/src/lighttpd') > mtime($self->{BASEDIR}.'/build/lighttpd')) {
35		$self->{BINDIR} = $self->{BASEDIR}.'/src';
36		if (mtime($self->{BASEDIR}.'/src/.libs')) {
37			$self->{MODULES_PATH} = $self->{BASEDIR}.'/src/.libs';
38		} else {
39			$self->{MODULES_PATH} = $self->{BASEDIR}.'/src';
40		}
41	} else {
42		$self->{BINDIR} = $self->{BASEDIR}.'/build';
43		$self->{MODULES_PATH} = $self->{BASEDIR}.'/build';
44	}
45	$self->{LIGHTTPD_PATH} = $self->{BINDIR}.'/lighttpd';
46	$self->{PORT} = 2048;
47
48	my ($name, $aliases, $addrtype, $net) = gethostbyaddr(inet_aton("127.0.0.1"), AF_INET);
49
50	$self->{HOSTNAME} = $name;
51
52	bless($self, $class);
53
54	return $self;
55}
56
57sub listening_on {
58	my $self = shift;
59	my $port = shift;
60
61	my $remote =
62 	  IO::Socket::INET->new(Proto    => "tcp",
63				PeerAddr => "127.0.0.1",
64				PeerPort => $port) or return 0;
65
66	close $remote;
67
68	return 1;
69}
70
71sub stop_proc {
72	my $self = shift;
73
74	my $pid = $self->{LIGHTTPD_PID};
75	if (defined $pid && $pid != -1) {
76		kill('TERM', $pid) or return -1;
77		return -1 if ($pid != waitpid($pid, 0));
78	} else {
79		diag("\nProcess not started, nothing to stop");
80		return -1;
81	}
82
83	return 0;
84}
85
86sub wait_for_port_with_proc {
87	my $self = shift;
88	my $port = shift;
89	my $child = shift;
90	my $timeout = 5*10; # 5 secs, select waits 0.1 s
91
92	while (0 == $self->listening_on($port)) {
93		select(undef, undef, undef, 0.1);
94		$timeout--;
95
96		# the process is gone, we failed
97		if (0 != waitpid($child, WNOHANG)) {
98			return -1;
99		}
100		if (0 >= $timeout) {
101			diag("\nTimeout while trying to connect; killing child");
102			kill('TERM', $child);
103			return -1;
104		}
105	}
106
107	return 0;
108}
109
110sub start_proc {
111	my $self = shift;
112	# kill old proc if necessary
113	#$self->stop_proc;
114
115	# pre-process configfile if necessary
116	#
117
118	$ENV{'SRCDIR'} = $self->{BASEDIR}.'/tests';
119	$ENV{'PORT'} = $self->{PORT};
120
121	my $cmdline = $self->{LIGHTTPD_PATH}." -D -f ".$self->{SRCDIR}."/".$self->{CONFIGFILE}." -m ".$self->{MODULES_PATH};
122	if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') {
123		$cmdline = "strace -tt -s 512 -o strace ".$cmdline;
124	} elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') {
125		$cmdline = "truss -a -l -w all -v all -o strace ".$cmdline;
126	} elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') {
127		$cmdline = "gdb --batch --ex 'run' --ex 'bt full' --args ".$cmdline." > gdb.out";
128	} elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') {
129		$cmdline = "valgrind --tool=memcheck --show-reachable=yes --leak-check=yes --log-file=valgrind ".$cmdline;
130	}
131	# diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".$cmdline );
132	my $child = fork();
133	if (not defined $child) {
134		diag("\nFork failed");
135		return -1;
136	}
137	if ($child == 0) {
138		exec $cmdline or die($?);
139	}
140
141	if (0 != $self->wait_for_port_with_proc($self->{PORT}, $child)) {
142		diag(sprintf('\nThe process %i is not up', $child));
143		return -1;
144	}
145
146	$self->{LIGHTTPD_PID} = $child;
147
148	0;
149}
150
151sub handle_http {
152	my $self = shift;
153	my $t = shift;
154	my $EOL = "\015\012";
155	my $BLANK = $EOL x 2;
156	my $host = "127.0.0.1";
157
158	my @request = $t->{REQUEST};
159	my @response = $t->{RESPONSE};
160	my $slow = defined $t->{SLOWREQUEST};
161	my $is_debug = $ENV{"TRACE_HTTP"};
162
163	my $remote =
164 	  IO::Socket::INET->new(Proto    => "tcp",
165				PeerAddr => $host,
166				PeerPort => $self->{PORT});
167
168	if (not defined $remote) {
169		diag("\nconnect failed: $!");
170	       	return -1;
171	}
172
173	$remote->autoflush(1);
174
175	if (!$slow) {
176		diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
177		foreach(@request) {
178			# pipeline requests
179			s/\r//g;
180			s/\n/$EOL/g;
181
182			print $remote $_.$BLANK;
183			diag("\n<< ".$_) if $is_debug;
184		}
185		shutdown($remote, 1); # I've stopped writing data
186	} else {
187		diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
188		foreach(@request) {
189			# pipeline requests
190			chomp;
191			s/\r//g;
192			s/\n/$EOL/g;
193
194			print $remote $_;
195			diag("<< ".$_."\n") if $is_debug;
196			select(undef, undef, undef, 0.1);
197			print $remote "\015";
198			select(undef, undef, undef, 0.1);
199			print $remote "\012";
200			select(undef, undef, undef, 0.1);
201			print $remote "\015";
202			select(undef, undef, undef, 0.1);
203			print $remote "\012";
204			select(undef, undef, undef, 0.1);
205		}
206
207	}
208	diag("\n... done") if $is_debug;
209
210	my $lines = "";
211
212	diag("\nreceiving response") if $is_debug;
213	# read everything
214	while(<$remote>) {
215		$lines .= $_;
216		diag(">> ".$_) if $is_debug;
217	}
218	diag("\n... done") if $is_debug;
219
220	close $remote;
221
222	my $full_response = $lines;
223
224	my $href;
225	foreach $href ( @{ $t->{RESPONSE} }) {
226		# first line is always response header
227		my %resp_hdr;
228		my $resp_body;
229		my $resp_line;
230		my $conditions = $_;
231
232		for (my $ln = 0; defined $lines; $ln++) {
233			(my $line, $lines) = split($EOL, $lines, 2);
234
235			# header finished
236			last if(!defined $line or length($line) == 0);
237
238			if ($ln == 0) {
239				# response header
240				$resp_line = $line;
241			} else {
242				# response vars
243
244				if ($line =~ /^([^:]+):\s*(.+)$/) {
245					(my $h = $1) =~ tr/[A-Z]/[a-z]/;
246
247					if (defined $resp_hdr{$h}) {
248# 						diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",
249# 						             $h, $resp_hdr{$h}, $2));
250						$resp_hdr{$h} .= ', '.$2;
251					} else {
252						$resp_hdr{$h} = $2;
253					}
254				} else {
255					diag(sprintf("\nunexpected line '%s'", $line));
256					return -1;
257				}
258			}
259		}
260
261		if (not defined($resp_line)) {
262			diag(sprintf("\nempty response"));
263			return -1;
264		}
265
266		$t->{etag} = $resp_hdr{'etag'};
267		$t->{date} = $resp_hdr{'date'};
268
269		# check length
270		if (defined $resp_hdr{"content-length"}) {
271			$resp_body = substr($lines, 0, $resp_hdr{"content-length"});
272			if (length($lines) < $resp_hdr{"content-length"}) {
273				$lines = "";
274			} else {
275				$lines = substr($lines, $resp_hdr{"content-length"});
276			}
277			undef $lines if (length($lines) == 0);
278		} else {
279			$resp_body = $lines;
280			undef $lines;
281		}
282
283		# check conditions
284		if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) {
285			if ($href->{'HTTP-Protocol'} ne $1) {
286				diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1));
287				return -1;
288			}
289			if ($href->{'HTTP-Status'} ne $2) {
290				diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2));
291				return -1;
292			}
293		} else {
294			diag(sprintf("\nunexpected resp_line '%s'", $resp_line));
295			return -1;
296		}
297
298		if (defined $href->{'HTTP-Content'}) {
299			$resp_body = "" unless defined $resp_body;
300			if ($href->{'HTTP-Content'} ne $resp_body) {
301				diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body));
302				return -1;
303			}
304		}
305
306		if (defined $href->{'-HTTP-Content'}) {
307			if (defined $resp_body && $resp_body ne '') {
308				diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body));
309				return -1;
310			}
311		}
312
313		foreach (keys %{ $href }) {
314			next if $_ eq 'HTTP-Protocol';
315			next if $_ eq 'HTTP-Status';
316			next if $_ eq 'HTTP-Content';
317			next if $_ eq '-HTTP-Content';
318
319			(my $k = $_) =~ tr/[A-Z]/[a-z]/;
320
321			my $verify_value = 1;
322			my $key_inverted = 0;
323
324			if (substr($k, 0, 1) eq '+') {
325				$k = substr($k, 1);
326				$verify_value = 0;
327			} elsif (substr($k, 0, 1) eq '-') {
328				## the key should NOT exist
329				$k = substr($k, 1);
330				$key_inverted = 1;
331				$verify_value = 0; ## skip the value check
332                        }
333
334			if ($key_inverted) {
335				if (defined $resp_hdr{$k}) {
336					diag(sprintf("\nheader '%s' MUST not be set", $k));
337					return -1;
338				}
339			} else {
340				if (not defined $resp_hdr{$k}) {
341					diag(sprintf("\nrequired header '%s' is missing", $k));
342					return -1;
343				}
344			}
345
346			if ($verify_value) {
347				if ($href->{$_} =~ /^\/(.+)\/$/) {
348					if ($resp_hdr{$k} !~ /$1/) {
349						diag(sprintf("\nresponse-header failed: expected '%s', got '%s', regex: %s",
350					             $href->{$_}, $resp_hdr{$k}, $1));
351						return -1;
352					}
353				} elsif ($href->{$_} ne $resp_hdr{$k}) {
354					diag(sprintf("\nresponse-header failed: expected '%s', got '%s'",
355					     $href->{$_}, $resp_hdr{$k}));
356					return -1;
357				}
358			}
359		}
360	}
361
362	# we should have sucked up everything
363	if (defined $lines) {
364		diag(sprintf("\nunexpected lines '%s'", $lines));
365		return -1;
366	}
367
368	return 0;
369}
370
371sub spawnfcgi {
372	my ($self, $binary, $port) = @_;
373	my $child = fork();
374	if (not defined $child) {
375		diag("\nCouldn't fork");
376		return -1;
377	}
378	if ($child == 0) {
379		my $iaddr   = inet_aton('localhost') || die "no host: localhost";
380		my $proto   = getprotobyname('tcp');
381		socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
382		setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!";
383		bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!";
384		listen(SOCK, 1024) || die "listen: $!";
385		dup2(fileno(SOCK), 0) || die "dup2: $!";
386		exec $binary or die($?);
387	} else {
388		if (0 != $self->wait_for_port_with_proc($port, $child)) {
389			diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary));
390			return -1;
391		}
392		return $child;
393	}
394}
395
396sub endspawnfcgi {
397	my ($self, $pid) = @_;
398	return -1 if (-1 == $pid);
399	kill(2, $pid);
400	waitpid($pid, 0);
401	return 0;
402}
403
4041;
405