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