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 my $ipproto_tcp = defined &Socket::IPPROTO_TCP ? Socket::IPPROTO_TCP : 6; 278 my $tcp_nodelay = defined &Socket::TCP_NODELAY ? Socket::TCP_NODELAY : 1; 279 $remote->setsockopt($ipproto_tcp, $tcp_nodelay, 1); # (ignore rc) 280 281 diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug; 282 foreach(@request) { 283 # pipeline requests 284 chomp; 285 s/\r//g; 286 s/\n/$EOL/g; 287 288 diag("<< ".$_."\n") if $is_debug; 289 if (!$slow) { 290 print $remote $_,$BLANK; 291 } 292 else { 293 print $remote $_; 294 print $remote "\015"; 295 print $remote "\012"; 296 print $remote "\015"; 297 print $remote "\012"; 298 } 299 } 300 shutdown($remote, 1) if ($^O ne "openbsd" && $^O ne "dragonfly"); # I've stopped writing data 301 diag("\n... done") if $is_debug; 302 303 my $lines = ""; 304 305 diag("\nreceiving response") if $is_debug; 306 # read everything 307 while(<$remote>) { 308 $lines .= $_; 309 diag(">> ".$_) if $is_debug; 310 } 311 diag("\n... done") if $is_debug; 312 313 close $remote; 314 315 my $full_response = $lines; 316 317 my $href; 318 foreach $href ( @{ $t->{RESPONSE} }) { 319 # first line is always response header 320 my %resp_hdr; 321 my $resp_body; 322 my $resp_line; 323 my $conditions = $_; 324 325 for (my $ln = 0; defined $lines; $ln++) { 326 (my $line, $lines) = split($EOL, $lines, 2); 327 328 # header finished 329 last if(!defined $line or length($line) == 0); 330 331 if ($ln == 0) { 332 # response header 333 $resp_line = $line; 334 } else { 335 # response vars 336 337 if ($line =~ /^([^:]+):\s*(.+)$/) { 338 (my $h = $1) =~ tr/[A-Z]/[a-z]/; 339 340 if (defined $resp_hdr{$h}) { 341# diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n", 342# $h, $resp_hdr{$h}, $2)); 343 $resp_hdr{$h} .= ', '.$2; 344 } else { 345 $resp_hdr{$h} = $2; 346 } 347 } else { 348 diag(sprintf("\nunexpected line '%s'", $line)); 349 return -1; 350 } 351 } 352 } 353 354 if (not defined($resp_line)) { 355 diag(sprintf("\nempty response")); 356 return -1; 357 } 358 359 $t->{etag} = $resp_hdr{'etag'}; 360 $t->{date} = $resp_hdr{'date'}; 361 362 # check length 363 if (defined $resp_hdr{"content-length"}) { 364 $resp_body = substr($lines, 0, $resp_hdr{"content-length"}); 365 if (length($lines) < $resp_hdr{"content-length"}) { 366 $lines = ""; 367 } else { 368 $lines = substr($lines, $resp_hdr{"content-length"}); 369 } 370 undef $lines if (length($lines) == 0); 371 } else { 372 $resp_body = $lines; 373 undef $lines; 374 } 375 376 # check conditions 377 if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) { 378 if ($href->{'HTTP-Protocol'} ne $1) { 379 diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1)); 380 return -1; 381 } 382 if ($href->{'HTTP-Status'} ne $2) { 383 diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2)); 384 return -1; 385 } 386 } else { 387 diag(sprintf("\nunexpected resp_line '%s'", $resp_line)); 388 return -1; 389 } 390 391 if (defined $href->{'HTTP-Content'}) { 392 $resp_body = "" unless defined $resp_body; 393 if ($href->{'HTTP-Content'} ne $resp_body) { 394 diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body)); 395 return -1; 396 } 397 } 398 399 if (defined $href->{'-HTTP-Content'}) { 400 if (defined $resp_body && $resp_body ne '') { 401 diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body)); 402 return -1; 403 } 404 } 405 406 foreach (keys %{ $href }) { 407 next if $_ eq 'HTTP-Protocol'; 408 next if $_ eq 'HTTP-Status'; 409 next if $_ eq 'HTTP-Content'; 410 next if $_ eq '-HTTP-Content'; 411 412 (my $k = $_) =~ tr/[A-Z]/[a-z]/; 413 414 my $verify_value = 1; 415 my $key_inverted = 0; 416 417 if (substr($k, 0, 1) eq '+') { 418 $k = substr($k, 1); 419 $verify_value = 0; 420 } elsif (substr($k, 0, 1) eq '-') { 421 ## the key should NOT exist 422 $k = substr($k, 1); 423 $key_inverted = 1; 424 $verify_value = 0; ## skip the value check 425 } 426 427 if ($key_inverted) { 428 if (defined $resp_hdr{$k}) { 429 diag(sprintf("\nheader '%s' MUST not be set", $k)); 430 return -1; 431 } 432 } else { 433 if (not defined $resp_hdr{$k}) { 434 diag(sprintf("\nrequired header '%s' is missing", $k)); 435 return -1; 436 } 437 } 438 439 if ($verify_value) { 440 if ($href->{$_} =~ /^\/(.+)\/$/) { 441 if ($resp_hdr{$k} !~ /$1/) { 442 diag(sprintf( 443 "\nresponse-header failed: expected '%s', got '%s', regex: %s", 444 $href->{$_}, $resp_hdr{$k}, $1)); 445 return -1; 446 } 447 } elsif ($href->{$_} ne $resp_hdr{$k}) { 448 diag(sprintf( 449 "\nresponse-header failed: expected '%s', got '%s'", 450 $href->{$_}, $resp_hdr{$k})); 451 return -1; 452 } 453 } 454 } 455 } 456 457 # we should have sucked up everything 458 if (defined $lines) { 459 diag(sprintf("\nunexpected lines '%s'", $lines)); 460 return -1; 461 } 462 463 return 0; 464} 465 466sub spawnfcgi { 467 my ($self, $binary, $port) = @_; 468 my $child = fork(); 469 if (not defined $child) { 470 diag("\nCouldn't fork"); 471 return -1; 472 } 473 if ($child == 0) { 474 my $iaddr = inet_aton('localhost') || die "no host: localhost"; 475 my $proto = getprotobyname('tcp'); 476 socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; 477 setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; 478 bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!"; 479 listen(SOCK, 1024) || die "listen: $!"; 480 require POSIX; 481 POSIX::dup2(fileno(SOCK), 0) || die "dup2: $!"; 482 exec { $binary } ($binary) or die($?); 483 } else { 484 if (0 != $self->wait_for_port_with_proc($port, $child)) { 485 diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary)); 486 return -1; 487 } 488 return $child; 489 } 490} 491 492sub endspawnfcgi { 493 my ($self, $pid) = @_; 494 return -1 if (-1 == $pid); 495 kill(2, $pid); 496 waitpid($pid, 0); 497 return 0; 498} 499 500sub has_feature { 501 # quick-n-dirty crude parse of "lighttpd -V" 502 # (XXX: should be run on demand and only once per instance, then cached) 503 my ($self, $feature) = @_; 504 my $FH; 505 open($FH, "-|",$self->{LIGHTTPD_PATH}, "-V") || return 0; 506 while (<$FH>) { 507 return ($1 eq '+') if (/([-+]) \Q$feature\E/); 508 } 509 close $FH; 510 return 0; 511} 512 513sub has_crypto { 514 # quick-n-dirty crude parse of "lighttpd -V" 515 # (XXX: should be run on demand and only once per instance, then cached) 516 my ($self) = @_; 517 my $FH; 518 open($FH, "-|",$self->{LIGHTTPD_PATH}, "-V") || return 0; 519 while (<$FH>) { 520 #return 1 if (/[+] (?i:OpenSSL|mbedTLS|GnuTLS|WolfSSL|Nettle|NSS crypto) support/); 521 return 1 if (/[+] (?i:OpenSSL|mbedTLS|GnuTLS|WolfSSL|Nettle) support/); 522 } 523 close $FH; 524 return 0; 525} 526 5271; 528