root/trunk/t/52-chunked-upload.t @ 766

#!/usr/bin/perl

use strict;
use Perlbal::Test;
use Perlbal::Test::WebServer;
use Perlbal::Test::WebClient;
use IO::Socket::INET;
use Test::More 'no_plan';

# setup webserver
my $web_port = start_webserver();
ok($web_port, 'webserver started');

# setup perlbal
my $port = new_port();
my $dir = tempdir();

my $conf = qq{
SERVER aio_mode = none

CREATE POOL a
POOL a ADD 127.0.0.1:$web_port

CREATE SERVICE test
SET role = reverse_proxy
SET pool = a
SET connect_ahead = 0
SET listen = 127.0.0.1:$port
SET persist_client = 1
SET buffer_uploads_path = $dir
SET buffer_uploads = 1
ENABLE test
};

my $msock = start_server($conf);
ok($msock, 'perlbal started');

ok(! buffer_file_exists(), "no files in buffer directory");

# setup data
my $data = 'x' x 1_000_000;
my ($curpos, $clen) = (0, 0);

my $req;

# disable all of it
request("buffer_off", 500_000,
        "write:500",
        "write:5",
        "write:5",
        "write:5",
        "sleep:0.25",
        "exists",
        "write:100000",
        "write:60000",
        "write:1000",
        "finish",
        sub {
            my ($res) = @_;
            my $cont = $res->content;
            like($cont, qr/length = 500000/, "backend got right content-length");
        },
        "empty");

sub buffer_file_exists {
    opendir DIR, $dir
        or die "can't open dir\n";
    foreach (readdir(DIR)) {
        next if /^\./;
        return 1;
    }
    return 0;
}

# cmds can be:
#    write:<length>     writes <length> bytes
#    sleep:<duration>   sleeps <duration> seconds, may be fractional
#    finish             (sends any final writes and/or reads response)
#    close              close socket
#    sub {}             coderef to run.  gets passed response object
#    no-reason          response has no reason
#    reason:<reason>    did buffering for either "size", "rate", or "time"
#    empty              No files in temp buffer location
#    exists             Yes, a temporary file exists
sub request {
    my $testname = shift;
    my $len = shift || 0;
    my @cmds = @_;

    my $curpos = 0;
    my $remain = $len;

    my $hdr = "POST /status HTTP/1.0\r\nTransfer-Encoding: chunked\r\nExpect: 100-continue\r\n\r\n";
    my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port" )
        or return undef;
    my $rv = syswrite($sock, $hdr);
    die unless $rv == length($hdr);

    # wanting HTTP/1.1 100 Continue\r\n...\r\n lines
    {
        my $contline = <$sock>;
        die "didn't get 100 Continue line, got: $contline"
            unless $contline =~ m!^HTTP/1.1 100!;
        my $gotempty = 0;
        while (defined(my $line = <$sock>)) {
            if ($line eq "\r\n") {
                $gotempty = 1;
                last;
            }
        }
        die "didn't get empty line after 100 Continue" unless $gotempty;
    }

    my $res = undef;  # no response yet

    foreach my $cmd (@cmds) {
        my $writelen;

        if ($cmd =~ /^write:([\d_]+)/) {
            $writelen = $1;
            $writelen =~ s/_//g;
        } elsif ($cmd =~ /^(\d+)/) {
            $writelen = $1;
        } elsif ($cmd eq "finish") {
            $writelen = $remain;
        }

        if ($cmd =~ /^sleep:([\d\.]+)/) {
            select undef, undef, undef, $1;
            next;
        }

        if ($cmd eq "close") {
            close($sock);
            next;
        }

        if ($cmd eq "exists") {
            ok(buffer_file_exists(), "$testname: buffer file exists");
            next;
        }

        if ($cmd eq "empty") {
            ok(! buffer_file_exists(), "$testname: no file");
            next;
        }

        if ($writelen) {
            die "Too long" if $writelen > $remain;
            my $buf = "x" x $writelen;
            $buf = sprintf("%x\r\n", $writelen) . $buf . "\r\n";
            $remain -= $writelen;
            if ($remain == 0) {
                # one \r\n for chunk ending, one for chunked-body ending,
                # after (our empty) trailer...
                $buf .= "0\r\n\r\n";
            }
            my $bufsize = length($buf);
            my $off = 0;
            while ($off < $bufsize) {
                my $rv = syswrite($sock, $buf, $bufsize-$off, $off);
                die "Error writing: $!" unless defined $rv;
                die "Got rv=0 from syswrite" unless $rv;
                $off += $rv;
            }

            next unless $cmd eq "finish";
        }

        if ($cmd eq "finish") {
            $res = resp_from_sock($sock);
            my $clen = $res ? $res->header('Content-Length') : 0;
            ok($res && length($res->content) == $clen, "$testname: good response");
            next;
        }

        if (ref $cmd eq "CODE") {
            $cmd->($res, $testname);
            next;
        }

        die "Invalid command: $cmd\n";
    }
}

# Try a 0 length chunked request, as it used to crash server
{
    my $hdr = "POST /status HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\n0\r\n\r\n";
    my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port" )
        or return undef;
    my $rv = syswrite($sock, $hdr);
    die unless $rv == length($hdr);

    # Give it time to crash
    select undef, undef, undef, 1.0;

    my $sock2 = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port" );
    ok ($sock2, 'Server still alive');
}

1;