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