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