Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

259 lines (215 sloc) 6.071 kb
#!/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
};
$ENV{PERLBAL_DEBUG_BUFFERED_UPLOADS} = 1;
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
buffer_rules();
request("buffer_off", 500_000,
"finish",
"no-reason",
"empty");
# try writing 400k of a 500k file, and set the buffer size to be "anything
# larger than 400k"
buffer_rules(size => 400_000);
request("buffer_on_size", 500_000,
400_000,
"sleep:0.5",
"exists",
"finish",
"reason:size",
"empty");
# write a file below the limit
request("no_buffer_on_size", 350_000,
300_000,
"sleep:0.5",
"empty",
"finish",
"no-reason",
"empty");
# abort a file in the middle
request("clean_on_early_close", 500_000,
400_000,
"sleep:0.5",
"exists",
"close",
"sleep:0.5", # have to let the pb get scheduled to do cleanup
"empty",
);
# rate tests
# need to write at least 250k (default size threshold)
buffer_rules(rate => 300_000);
request("buffer_on_rate", 1_000_000,
50_000,
"sleep:2",
"empty",
300_000,
"sleep:2",
300_000,
"exists",
"finish",
"reason:rate",
"empty");
request("no_buffer_on_rate", 500_000,
"finish",
"no-reason",
"empty");
# time tests
buffer_rules(time => 3);
request("buffer_on_time", 800_000,
"sleep:2",
300_000,
"sleep:0.5",
"exists",
"finish",
"reason:time",
"empty");
request("no_buffer_on_time", 800_000,
700_000,
"sleep:0.2",
"empty",
"finish",
"no-reason");
sub buf_reason {
my $resp = shift;
return "" unless $resp && $resp->content =~ /^buffered = (\S+)$/m;
return $1;
}
sub buffer_rules {
my %opts = @_;
my $size = delete $opts{size};
my $rate = delete $opts{rate};
my $time = delete $opts{time};
die "bogus opts" if %opts;
# if they don't provide a value, set it to 0, which means threshold ignored
set_threshold('size', $size || 0);
set_threshold('rate', $rate || 0);
set_threshold('time', $time || 0);
}
sub set_threshold {
my ($which, $what) = @_;
manage("SET test.buffer_upload_threshold_$which = $what");
}
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\nContent-length: $len\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);
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 "no-reason") {
ok(! buf_reason($res), "$testname: no buffer reason");
next;
}
if ($cmd =~ /^reason:(\w+)$/) {
my $reason = $1;
is(buf_reason($res), $reason, "$testname: did buffer for $reason");
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;
my $rv = syswrite($sock, $buf);
die "wrote $rv ($!), not $len" unless $rv == $writelen;
$remain -= $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";
}
}
sub pid_of_resp {
my $resp = shift;
return 0 unless $resp && $resp->content =~ /^pid = (\d+)$/m;
return $1;
}
1;
Jump to Line
Something went wrong with that request. Please try again.