File Coverage

blib/lib/Perlbal/Test/WebServer.pm

Criterion	Covered	Total	%
statement	162	167	97.0
branch	69	88	78.4
condition	28	42	66.6
subroutine	14	14	100.0
pod	0	3	0.0
total	273	314	86.9

#!/usr/bin/perl

package Perlbal::Test::WebServer;

use strict;
use IO::Socket::INET;
use HTTP::Request;
use Socket qw(MSG_NOSIGNAL IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
use Perlbal::Test;

use Perlbal::Test::WebClient;

require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(start_webserver);

our @webserver_pids;

my $testpid; # of the test suite's main program, the one running the HTTP client

END {
    # ensure we kill off the webserver
    kill 9, @webserver_pids if $testpid && $testpid == $$;
}


sub start_webserver {
    my $port = new_port();

    # dummy mode
    if ($ENV{'TEST_PERLBAL_USE_EXISTING'}) {
        return $port;
    }

    $testpid = $$;

    if (my $child = fork) {
        # i am parent, wait for child to startup
        push @webserver_pids, $child;
        my $sock = wait_on_child($child, $port);
        die "Unable to spawn webserver on port $port\n"
            unless $sock;
        print $sock "GET /reqdecr,status HTTP/1.0\r\n\r\n";
        my $line = <$sock>;
        die "Didn't get 200 OK: " . (defined $line ? $line : "(undef)")
            unless $line && $line =~ /200 OK/;
        return $port;
    }

    # i am child, start up
    my $ssock = IO::Socket::INET->new(LocalPort => $port, ReuseAddr => 1, Listen => 3)
        or die "Unable to start socket: $!\n";
    while (my $csock = $ssock->accept) {
        exit 0 unless $csock;
        fork and next; # parent starts waiting for next request
        setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
        serve_client($csock);
    }
}

sub serve_client {
    my $csock = shift;
    my $req_num = 0;
    my $did_options = 0;
    my @reqs;

  REQ:
    while (1) {
        my $req = '';
        my $clen = undef;
        while (<$csock>) {
            $req .= $_;
            if (/^content-length:\s*(\d+)/i) { $clen = $1; };
            last if ! $_ || /^\r?\n/;
        }
        exit 0 unless $req;

        # parse out things we want to have
        my @cmds;
        my $httpver = 0; # 0 = 1.0, 1 = 1.1, undef = neither
        my $method;
        if ($req =~ m!^([A-Z]+) /?(\S+) HTTP/(1\.\d+)\r?\n?!) {
            $method = $1;
            my $cmds = durl($2);
            @cmds = split(/\s*,\s*/, $cmds);
            $req_num++;
            $httpver = ($3 eq '1.0' ? 0 : ($3 eq '1.1' ? 1 : undef));
        }
        my $msg = HTTP::Request->parse($req);
        my $keeping_alive = undef;

        my $body;
        if ($clen) {
            die "Can't read a body on a GET or HEAD" if $method =~ /^GET|HEAD$/;
            my $read = read $csock, $body, $clen;
            die "Didn't read $clen bytes.  Got $read." if $clen != $read;
        }

        my $response = sub {
            my %opts = @_;
            my $code = delete $opts{code};
            my $codetext = delete $opts{codetext};
            my $content = delete $opts{content};
            my $ctype = delete $opts{type};
            my $extra_hdr = delete $opts{headers};
            die "unknown data in opts: %opts" if %opts;

            $extra_hdr ||= '';
            $code ||= $content ? 200 : 200;
            $codetext ||= { 200 => 'OK', 500 => 'Internal Server Error', 204 => "No Content" }->{$code};
            $content ||= "";

            my $clen = length $content;
            $ctype ||= "text/plain" unless $code == 204;
            $extra_hdr .= "Content-Type: $ctype\r\n" if $ctype;

            my $hdr_keepalive = "";

            unless (defined $keeping_alive) {
                my $hdr_connection = $msg->header('Connection') || '';
                if ($httpver == 1) {
                    if ($hdr_connection =~ /\bclose\b/i) {
                        $keeping_alive = 0;
                    } else {
                        $keeping_alive = "1.1implicit";
                    }
                }
                if ($httpver == 0 && $hdr_connection =~ /\bkeep-alive\b/i) {
                    $keeping_alive = "1.0keepalive";
                }
            }

            if ($keeping_alive) {
                $hdr_keepalive = "Connection: keep-alive\n";
            } else {
                $hdr_keepalive = "Connection: close\n";
            }

            return "HTTP/1.0 $code $codetext\r\n" .
                $hdr_keepalive .
                "Content-Length: $clen\r\n" .
                $extra_hdr .
                "\r\n" .
                "$content";
        };

        my $send = sub {
            my $res = shift;
            print $csock $res;
            exit 0 unless $keeping_alive;
        };

        # 500 if no commands were given or we don't know their HTTP version
        # or we didn't parse a proper HTTP request
        unless (@cmds && defined $httpver && $msg) {
            print STDERR "500 response!\n";
            $send->($response->(code => 500));
            next REQ;
        }

        if ($method eq "OPTIONS") {
            $did_options = 1;
            $send->($response->(code => 200));
            next REQ;
        }

        # prepare a simple 200 to send; undef this if you want to control
        # your own output below
        my $to_send;

        foreach my $cmd (@cmds) {
            $cmd =~ s/^\s+//;
            $cmd =~ s/\s+$//;

            if ($cmd =~ /^sleep:([\d\.]+)$/i) {
                my $sleeptime = $1;
                #print "I, $$, should sleep for $sleeptime.\n";
                use Time::HiRes;
                my $t1 = Time::HiRes::time();
                select undef, undef, undef, $1;
                my $t2 = Time::HiRes::time();
                my $td = $t2 - $t1;
                #print "I, $$, slept for $td\n";
            }

            if ($cmd =~ /^keepalive:([01])$/i) {
                $keeping_alive = $1;
            }

            if ($cmd eq "status") {
                my $len = $clen || 0;
                my $bu = $msg->header('X-PERLBAL-BUFFERED-UPLOAD-REASON') || '';
                $to_send = $response->(content =>
                                       "pid = $$\nreqnum = $req_num\nmethod = $method\n".
                                       "length = $len\nbuffered = $bu\noptions = $did_options\n");
            }

            if ($cmd eq "reqdecr") {
                $req_num--;
            }

            if ($cmd =~ /^kill:(\d+):(\w+)$/) {
                kill $2, $1;
            }

            if ($cmd =~ /^reproxy_url:(.+)/i) {
                $to_send = $response->(headers => "X-Reproxy-URL: $1\r\n",
                                       code => 204,
                                       );
            }

            if ($cmd =~ /^reproxy_url204:(.+)/i) {
                $to_send = $response->(headers => "X-Reproxy-URL: $1\r\n");
            }

            if ($cmd =~ /^reproxy_url_cached:(\d+):(.+)/i) {
                kill 'USR1', $testpid;
                $to_send = $response->(headers =>
                                       "X-Reproxy-URL: $2\r\nX-Reproxy-Cache-For: $1; Last-Modified Content-Type\r\nLast-Modified: 199\r\nContent-Type: application/badger\r\n");
            }

            if ($cmd =~ /^reproxy_url_multi:((?:\d+:){2,})(\S+)/i) {
                my $ports = $1;
                my $path = $2;
                my @urls;
                foreach my $port (split(/:/, $ports)) {
                    push @urls, "http://127.0.0.1:$port$path";
                }
                $to_send = $response->(headers => "X-Reproxy-URL: @urls\r\n");
            }

            if ($cmd =~ /^reproxy_file:(.+)/i) {
                $to_send = $response->(headers => "X-Reproxy-File: $1\r\n");
            }

            if ($cmd =~ /^subreq:(\d+)$/) {
                my $port = $1;
                my $wc = Perlbal::Test::WebClient->new;
                $wc->server("127.0.0.1:$port");
                $wc->keepalive(0);
                $wc->http_version('1.0');
                my $resp = $wc->request("status");
                my $subpid;
                if ($resp && $resp->content =~ /^pid = (\d+)$/m) {
                    $subpid = $1;
                }
                $to_send = $response->(content => "pid = $$\nsubpid = $subpid\nreqnum = $req_num\n");
            }

            if ($cmd =~ /^reflect_request_headers$/) {
                $to_send = $response->(content => $msg->headers->as_string);
            }
        }

        $send->($to_send || $response->());
    } # while(1)
}

# de-url escape
sub durl {
    my ($a) = @_;
    $a =~ tr/+/ /;
    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    return $a;
}

1;