tests/LightyTest.pm

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