init

2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
--- a/wcmtools/perlbal/t/00-use.t
+++ b/wcmtools/perlbal/t/00-use.t
@@ -0,0 +1,8 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 1;
+
+use Perlbal;
+
+ok(1);
--- a/wcmtools/perlbal/t/10-testharness.t
+++ b/wcmtools/perlbal/t/10-testharness.t
@@ -0,0 +1,10 @@
+#!/usr/bin/perl
+
+use strict;
+use Perlbal::Test;
+use Test::More 'no_plan';
+
+my $msock = start_server("");
+ok($msock);
+
+1;
--- a/wcmtools/perlbal/t/12-headers.t
+++ b/wcmtools/perlbal/t/12-headers.t
@@ -0,0 +1,38 @@
+#!/usr/bin/perl
+
+use strict;
+use Perlbal::Test;
+use Test::More 'no_plan';
+
+use Perlbal;
+use Perlbal::HTTPHeaders;
+eval "use Perlbal::XS::HTTPHeaders;";
+
+# classes we will be testing
+my @classes = ('Perlbal::HTTPHeaders');
+push @classes, $Perlbal::XSModules{headers}
+    if $Perlbal::XSModules{headers};
+
+# verify they work
+foreach my $class (@classes) {
+    # basic request, just tests to see if the class is functioning
+    my $req = \"GET / HTTP/1.0\r\n\r\n";
+    my $c_req = $class->new($req);
+    ok($c_req, "basic request - $class");
+
+    # basic response, same
+    my $resp = \"HTTP/1.0 200 OK\r\n\r\n";
+    my $c_resp = $class->new($resp, 1);
+    ok($c_resp, "basic response - $class");
+
+    # test for a bug in the XS headers that caused headers with no content
+    # to be disconnected from the server
+    my $hdr = \"GET / HTTP/1.0\r\nHeader: content\r\nAnother: \r\nSomething:\r\n\r\n";
+    my $obj = $class->new($hdr);
+    ok($obj, "headers without content 1 - $class");
+    is($obj->header('header'), 'content', "headers without content 2 - $class");
+    is($obj->header('anoTHER'), '', "headers without content 3 - $class");
+    is($obj->header('notthere'), undef, "headers without content 4 - $class");
+}
+
+1;
--- a/wcmtools/perlbal/t/15-webserver.t
+++ b/wcmtools/perlbal/t/15-webserver.t
@@ -0,0 +1,76 @@
+#!/usr/bin/perl
+
+use strict;
+use Perlbal::Test;
+
+use Test::More 'no_plan';
+require HTTP::Request;
+
+my $port = new_port();
+my $dir = tempdir();
+
+my $conf = qq{
+SERVER aio_mode = none
+
+CREATE SERVICE test
+SET test.role = web_server
+SET test.listen = 127.0.0.1:$port
+SET test.docroot = $dir
+SET test.dirindexing = 0
+SET test.persist_client = 1
+ENABLE test
+};
+
+my $msock = start_server($conf);
+ok($msock, "manage sock");
+my $ua = ua();
+ok($ua, "ua");
+
+my ($url, $disk_file, $contents);
+sub set_path {
+    my $path = shift;
+    $url = "http://127.0.0.1:$port$path";
+    $disk_file = "$dir$path";
+}
+sub set_contents {
+    $contents = shift;
+}
+sub write_file {
+    open(F, ">$disk_file") or die "Couldn't open $disk_file: $!\n";
+    print F $contents;
+    close F;
+}
+
+sub get {
+    my $url = shift;
+    my $req = HTTP::Request->new(GET => $url);
+    my $res = $ua->request($req);
+    return $res->is_success ? $res->content : undef;
+}
+
+# write a file to disk
+mkdir "$dir/foo";
+set_path("/foo/bar.txt");
+set_contents("foo bar baz\n" x 1000);
+write_file();
+ok(filecontent($disk_file) eq $contents, "disk file verify");
+
+# a simple get
+ok(get($url) eq $contents, "GET request");
+
+# 404 path
+ok(! get("$url/404.txt"), "missing file");
+
+# verify directory indexing is off
+{
+    my $dirurl = $url;
+    $dirurl =~ s!/[^/]+?$!/!;
+    my $diridx = get($dirurl);
+    like($diridx, qr/Directory listing disabled/, "no dirlist");
+    manage("SET test.dirindexing = 1");
+    $diridx = get($dirurl);
+    like($diridx, qr/bar\.txt/, "see dirlist");
+}
+
+
+1;
--- a/wcmtools/perlbal/t/20-put.t
+++ b/wcmtools/perlbal/t/20-put.t
@@ -0,0 +1,108 @@
+#!/usr/bin/perl
+
+use strict;
+use Perlbal::Test;
+
+use Test::More 'no_plan';
+
+my $port = new_port();
+my $dir = tempdir();
+
+my $conf = qq{
+SERVER aio_mode = none
+
+CREATE SERVICE test
+SET test.role = web_server
+SET test.listen = 127.0.0.1:$port
+SET test.docroot = $dir
+SET test.dirindexing = 0
+SET test.enable_put = 1
+SET test.enable_delete = 1
+SET test.min_put_directory = 0
+SET test.persist_client = 1
+ENABLE test
+};
+
+my $msock = start_server($conf);
+
+my $ua = ua();
+ok($ua);
+
+require HTTP::Request;
+
+my $url = "http://127.0.0.1:$port/foo.txt";
+my $disk_file = "$dir/foo.txt";
+my $content;
+
+sub put_file {
+    my $req = HTTP::Request->new(PUT => $url);
+    $content = "foo bar baz\n" x 1000;
+    $req->content($content);
+    my $res = $ua->request($req);
+    return $res->is_success;
+}
+
+sub delete_file {
+    my $req = HTTP::Request->new(DELETE => $url);
+    my $res = $ua->request($req);
+    return $res->is_success;
+}
+
+sub verify_put {
+    ok(filecontent($disk_file) eq $content, "verified put");
+}
+
+# successful puts
+foreach_aio {
+    my $aio = shift;
+
+    ok(put_file(), "$aio: good put");
+    verify_put();
+    unlink $disk_file;
+};
+
+# good delete
+put_file();
+ok(  -f $disk_file, "file exists");
+ok(delete_file(), "delete file");
+ok(! -f $disk_file, "file gone");
+ok(! delete_file(), "deleting non-existent file");
+
+# min_put_directory
+ok(manage("SET test.min_put_directory = 2"));
+foreach_aio {
+    my $mode = shift;
+
+    my $dir1 = "mode-$mode";
+    my $path = "$dir1/dir2/foo.txt";
+    $url = "http://127.0.0.1:$port/$path";
+    $disk_file = "$dir/$path";
+    ok(! put_file(), "aio $mode: bad put");
+    ok(mkdir("$dir/$dir1"), "mkdir dir1");
+    ok(mkdir("$dir/$dir1/dir2"), "mkdir dir1/dir2");
+    ok(put_file(), "aio $mode: good put at dir1/dir2/foo.txt");
+    verify_put();
+    ok(unlink($disk_file), "rm file");
+    ok(rmdir("$dir/$dir1/dir2"), "rm dir2");
+    ok(rmdir("$dir/$dir1"), "rm dir1");
+};
+
+ok(manage("SET test.min_put_directory = 0"));
+
+# let Perlbal autocreate a dir tree
+{
+    my $path = "a/b/c/d/foo.txt";
+    $url = "http://127.0.0.1:$port/$path";
+    $disk_file = "$dir/$path";
+    ok(put_file(), "made deep file");
+    ok(-f $disk_file, "deep file exists");
+}
+
+# permissions
+ok(put_file());
+ok(manage("SET test.enable_put = 0"));
+ok(! put_file(), "put disabled");
+ok(manage("SET test.enable_delete = 0"));
+ok(! delete_file(), "delete disabled");
+
+1;
--- a/wcmtools/perlbal/t/30-reverseproxy.t
+++ b/wcmtools/perlbal/t/30-reverseproxy.t
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use Perlbal::Test;
+use Perlbal::Test::WebServer;
+use Perlbal::Test::WebClient;
+use Test::More 'no_plan';
+
+# option setup
+my $start_servers = 3; # web servers to start
+
+# setup a few web servers that we can work with
+my @web_ports = map { start_webserver() } 1..$start_servers;
+@web_ports = grep { $_ > 0 } map { $_ += 0 } @web_ports;
+ok(scalar(@web_ports) == $start_servers, 'web servers started');
+
+# setup a simple perlbal that uses the above server
+my $pb_port = new_port();
+my $conf = qq{
+CREATE POOL a
+
+CREATE SERVICE test
+SET test.role = reverse_proxy
+SET test.listen = 127.0.0.1:$pb_port
+SET test.persist_client = 1
+SET test.persist_backend = 1
+SET test.pool = a
+ENABLE test
+
+};
+
+$conf .= "POOL a ADD 127.0.0.1:$_\n"
+    foreach @web_ports;
+
+my $msock = start_server($conf);
+ok($msock, 'perlbal started');
+
+my $wc = new Perlbal::Test::WebClient;
+$wc->server("127.0.0.1:$pb_port");
+$wc->keepalive(0);
+$wc->http_version('1.0');
+ok($wc, 'web client object created');
+
+my $resp = $wc->request('status');
+ok($resp, 'status response ok');
+
+my $content = $resp ? $resp->content : '';
+my $pid = $content =~ /^pid = (\d+)$/ ? $1 : 0;
+ok($pid > 0, 'web server functioning');
+
+1;