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 my $remote = IO::Socket::INET->new( 96 Proto => "tcp", 97 PeerAddr => "127.0.0.1", 98 PeerPort => $port) or return 0; 99 100 close $remote; 101 102 return 1; 103} 104 105sub stop_proc { 106 my $self = shift; 107 108 my $pid = $self->{LIGHTTPD_PID}; 109 if (defined $pid && $pid != -1) { 110 kill('TERM', $pid) or return -1; 111 return -1 if ($pid != waitpid($pid, 0)); 112 } else { 113 diag("\nProcess not started, nothing to stop"); 114 return -1; 115 } 116 117 return 0; 118} 119 120sub wait_for_port_with_proc { 121 my $self = shift; 122 my $port = shift; 123 my $child = shift; 124 my $timeout = 10*100; # 10 secs (valgrind might take a while), select waits 0.01 s 125 126 while (0 == $self->listening_on($port)) { 127 select(undef, undef, undef, 0.01); 128 $timeout--; 129 130 # the process is gone, we failed 131 require POSIX; 132 if (0 != waitpid($child, POSIX::WNOHANG)) { 133 return -1; 134 } 135 if (0 >= $timeout) { 136 diag("\nTimeout while trying to connect; killing child"); 137 kill('TERM', $child); 138 return -1; 139 } 140 } 141 142 return 0; 143} 144 145sub bind_ephemeral_tcp_socket { 146 my $SOCK; 147 socket($SOCK, PF_INET, SOCK_STREAM, 0) || die "socket: $!"; 148 setsockopt($SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; 149 bind($SOCK, sockaddr_in(0, INADDR_LOOPBACK)) || die "bind: $!"; 150 my($port) = sockaddr_in(getsockname($SOCK)); 151 return ($SOCK, $port); 152} 153 154sub get_ephemeral_tcp_port { 155 # bind to an ephemeral port, close() it, and return port that was used 156 # (While there is a race condition before caller may reuse the port, 157 # the port is likely to remain available for the serialized tests) 158 my $port; 159 (undef, $port) = bind_ephemeral_tcp_socket(); 160 return $port; 161} 162 163sub start_proc { 164 my $self = shift; 165 # kill old proc if necessary 166 #$self->stop_proc; 167 168 # listen on localhost and kernel-assigned ephemeral port 169 my $SOCK; 170 ($SOCK, $self->{PORT}) = bind_ephemeral_tcp_socket(); 171 172 # pre-process configfile if necessary 173 # 174 175 $ENV{'SRCDIR'} = $self->{BASEDIR}.'/tests'; 176 $ENV{'PORT'} = $self->{PORT}; 177 178 my @cmdline = ($self->{LIGHTTPD_PATH}, "-D", "-f", $self->{SRCDIR}."/".$self->{CONFIGFILE}, "-m", $self->{MODULES_PATH}); 179 splice(@cmdline, -2) if exists $ENV{LIGHTTPD_EXE_PATH}; 180 if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') { 181 @cmdline = (qw(strace -tt -s 4096 -o strace -f -v), @cmdline); 182 } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') { 183 @cmdline = (qw(truss -a -l -w all -v all -o strace), @cmdline); 184 } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') { 185 @cmdline = ('gdb', '--batch', '--ex', 'run', '--ex', 'bt full', '--args', @cmdline); 186 } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') { 187 @cmdline = (qw(valgrind --tool=memcheck --track-origins=yes --show-reachable=yes --leak-check=yes --log-file=valgrind.%p), @cmdline); 188 } 189 # diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".@cmdline ); 190 my $child = fork(); 191 if (not defined $child) { 192 diag("\nFork failed"); 193 close($SOCK); 194 return -1; 195 } 196 if ($child == 0) { 197 # set up systemd socket activation env vars 198 $ENV{LISTEN_FDS} = "1"; 199 $ENV{LISTEN_PID} = $$; 200 listen($SOCK, 1024) || die "listen: $!"; 201 if (fileno($SOCK) != 3) { # SD_LISTEN_FDS_START 3 202 require POSIX; 203 POSIX::dup2(fileno($SOCK), 3) || die "dup2: $!"; 204 close($SOCK); 205 } 206 else { 207 require Fcntl; 208 fcntl($SOCK, Fcntl::F_SETFD, 0); # clr FD_CLOEXEC 209 } 210 exec @cmdline or die($?); 211 } 212 close($SOCK); 213 214 if (0 != $self->wait_for_port_with_proc($self->{PORT}, $child)) { 215 diag(sprintf('\nThe process %i is not up', $child)); 216 return -1; 217 } 218 219 $self->{LIGHTTPD_PID} = $child; 220 221 0; 222} 223 224sub handle_http { 225 my $self = shift; 226 my $t = shift; 227 my $EOL = "\015\012"; 228 my $BLANK = $EOL x 2; 229 my $host = "127.0.0.1"; 230 231 my @request = $t->{REQUEST}; 232 my @response = $t->{RESPONSE}; 233 my $slow = defined $t->{SLOWREQUEST}; 234 my $is_debug = $ENV{"TRACE_HTTP"}; 235 236 my $remote = 237 IO::Socket::INET->new( 238 Proto => "tcp", 239 PeerAddr => $host, 240 PeerPort => $self->{PORT}); 241 242 if (not defined $remote) { 243 diag("\nconnect failed: $!"); 244 return -1; 245 } 246 247 $remote->autoflush(1); 248 249 if (!$slow) { 250 diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug; 251 foreach(@request) { 252 # pipeline requests 253 s/\r//g; 254 s/\n/$EOL/g; 255 256 print $remote $_.$BLANK; 257 diag("\n<< ".$_) if $is_debug; 258 } 259 shutdown($remote, 1) if ($^O ne "openbsd" && $^O ne "dragonfly"); # I've stopped writing data 260 } else { 261 diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug; 262 foreach(@request) { 263 # pipeline requests 264 chomp; 265 s/\r//g; 266 s/\n/$EOL/g; 267 268 print $remote $_; 269 diag("<< ".$_."\n") if $is_debug; 270 select(undef, undef, undef, 0.0001); 271 print $remote "\015"; 272 select(undef, undef, undef, 0.0001); 273 print $remote "\012"; 274 select(undef, undef, undef, 0.0001); 275 print $remote "\015"; 276 select(undef, undef, undef, 0.0001); 277 print $remote "\012"; 278 select(undef, undef, undef, 0.0001); 279 } 280 281 } 282 diag("\n... done") if $is_debug; 283 284 my $lines = ""; 285 286 diag("\nreceiving response") if $is_debug; 287 # read everything 288 while(<$remote>) { 289 $lines .= $_; 290 diag(">> ".$_) if $is_debug; 291 } 292 diag("\n... done") if $is_debug; 293 294 close $remote; 295 296 my $full_response = $lines; 297 298 my $href; 299 foreach $href ( @{ $t->{RESPONSE} }) { 300 # first line is always response header 301 my %resp_hdr; 302 my $resp_body; 303 my $resp_line; 304 my $conditions = $_; 305 306 for (my $ln = 0; defined $lines; $ln++) { 307 (my $line, $lines) = split($EOL, $lines, 2); 308 309 # header finished 310 last if(!defined $line or length($line) == 0); 311 312 if ($ln == 0) { 313 # response header 314 $resp_line = $line; 315 } else { 316 # response vars 317 318 if ($line =~ /^([^:]+):\s*(.+)$/) { 319 (my $h = $1) =~ tr/[A-Z]/[a-z]/; 320 321 if (defined $resp_hdr{$h}) { 322# diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n", 323# $h, $resp_hdr{$h}, $2)); 324 $resp_hdr{$h} .= ', '.$2; 325 } else { 326 $resp_hdr{$h} = $2; 327 } 328 } else { 329 diag(sprintf("\nunexpected line '%s'", $line)); 330 return -1; 331 } 332 } 333 } 334 335 if (not defined($resp_line)) { 336 diag(sprintf("\nempty response")); 337 return -1; 338 } 339 340 $t->{etag} = $resp_hdr{'etag'}; 341 $t->{date} = $resp_hdr{'date'}; 342 343 # check length 344 if (defined $resp_hdr{"content-length"}) { 345 $resp_body = substr($lines, 0, $resp_hdr{"content-length"}); 346 if (length($lines) < $resp_hdr{"content-length"}) { 347 $lines = ""; 348 } else { 349 $lines = substr($lines, $resp_hdr{"content-length"}); 350 } 351 undef $lines if (length($lines) == 0); 352 } else { 353 $resp_body = $lines; 354 undef $lines; 355 } 356 357 # check conditions 358 if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) { 359 if ($href->{'HTTP-Protocol'} ne $1) { 360 diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1)); 361 return -1; 362 } 363 if ($href->{'HTTP-Status'} ne $2) { 364 diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2)); 365 return -1; 366 } 367 } else { 368 diag(sprintf("\nunexpected resp_line '%s'", $resp_line)); 369 return -1; 370 } 371 372 if (defined $href->{'HTTP-Content'}) { 373 $resp_body = "" unless defined $resp_body; 374 if ($href->{'HTTP-Content'} ne $resp_body) { 375 diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body)); 376 return -1; 377 } 378 } 379 380 if (defined $href->{'-HTTP-Content'}) { 381 if (defined $resp_body && $resp_body ne '') { 382 diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body)); 383 return -1; 384 } 385 } 386 387 foreach (keys %{ $href }) { 388 next if $_ eq 'HTTP-Protocol'; 389 next if $_ eq 'HTTP-Status'; 390 next if $_ eq 'HTTP-Content'; 391 next if $_ eq '-HTTP-Content'; 392 393 (my $k = $_) =~ tr/[A-Z]/[a-z]/; 394 395 my $verify_value = 1; 396 my $key_inverted = 0; 397 398 if (substr($k, 0, 1) eq '+') { 399 $k = substr($k, 1); 400 $verify_value = 0; 401 } elsif (substr($k, 0, 1) eq '-') { 402 ## the key should NOT exist 403 $k = substr($k, 1); 404 $key_inverted = 1; 405 $verify_value = 0; ## skip the value check 406 } 407 408 if ($key_inverted) { 409 if (defined $resp_hdr{$k}) { 410 diag(sprintf("\nheader '%s' MUST not be set", $k)); 411 return -1; 412 } 413 } else { 414 if (not defined $resp_hdr{$k}) { 415 diag(sprintf("\nrequired header '%s' is missing", $k)); 416 return -1; 417 } 418 } 419 420 if ($verify_value) { 421 if ($href->{$_} =~ /^\/(.+)\/$/) { 422 if ($resp_hdr{$k} !~ /$1/) { 423 diag(sprintf( 424 "\nresponse-header failed: expected '%s', got '%s', regex: %s", 425 $href->{$_}, $resp_hdr{$k}, $1)); 426 return -1; 427 } 428 } elsif ($href->{$_} ne $resp_hdr{$k}) { 429 diag(sprintf( 430 "\nresponse-header failed: expected '%s', got '%s'", 431 $href->{$_}, $resp_hdr{$k})); 432 return -1; 433 } 434 } 435 } 436 } 437 438 # we should have sucked up everything 439 if (defined $lines) { 440 diag(sprintf("\nunexpected lines '%s'", $lines)); 441 return -1; 442 } 443 444 return 0; 445} 446 447sub spawnfcgi { 448 my ($self, $binary, $port) = @_; 449 my $child = fork(); 450 if (not defined $child) { 451 diag("\nCouldn't fork"); 452 return -1; 453 } 454 if ($child == 0) { 455 my $iaddr = inet_aton('localhost') || die "no host: localhost"; 456 my $proto = getprotobyname('tcp'); 457 socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; 458 setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; 459 bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!"; 460 listen(SOCK, 1024) || die "listen: $!"; 461 require POSIX; 462 POSIX::dup2(fileno(SOCK), 0) || die "dup2: $!"; 463 exec { $binary } ($binary) or die($?); 464 } else { 465 if (0 != $self->wait_for_port_with_proc($port, $child)) { 466 diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary)); 467 return -1; 468 } 469 return $child; 470 } 471} 472 473sub endspawnfcgi { 474 my ($self, $pid) = @_; 475 return -1 if (-1 == $pid); 476 kill(2, $pid); 477 waitpid($pid, 0); 478 return 0; 479} 480 481sub has_feature { 482 # quick-n-dirty crude parse of "lighttpd -V" 483 # (XXX: should be run on demand and only once per instance, then cached) 484 my ($self, $feature) = @_; 485 my $FH; 486 open($FH, "-|",$self->{LIGHTTPD_PATH}, "-V") || return 0; 487 while (<$FH>) { 488 return ($1 eq '+') if (/([-+]) \Q$feature\E/); 489 } 490 close $FH; 491 return 0; 492} 493 494sub has_crypto { 495 # quick-n-dirty crude parse of "lighttpd -V" 496 # (XXX: should be run on demand and only once per instance, then cached) 497 my ($self) = @_; 498 my $FH; 499 open($FH, "-|",$self->{LIGHTTPD_PATH}, "-V") || return 0; 500 while (<$FH>) { 501 return 1 if (/[+] (?i:OpenSSL|mbedTLS|GnuTLS|WolfSSL|Nettle|NSS crypto) support/); 502 } 503 close $FH; 504 return 0; 505} 506 5071; 508