Perlbal-1.80/0000755000175000017500000000000011722625030013211 5ustar dormandodormandoPerlbal-1.80/conf/0000755000175000017500000000000011722625030014136 5ustar dormandodormandoPerlbal-1.80/conf/ssl.conf0000644000175000017500000000273111503530123015604 0ustar dormandodormando# # This is an example webserver configuration using virtual hosts. # # See doc/config-guide.txt for descriptions of each command (line) # and configuration syntax. # ################################3 # # to use SSL mode, you'll need IO::Socket::SSL 0.97+ # # You can do SSL either on webserver mode, a reverse_proxy, or a service selector, # but not if the service selector is vhost-based, because SSL and vhosts aren't # compatible. # # the pound docs recommend this cipher list for a known bug in older # versions of IE: # # ALL:!ADH:!EXPORT56:RC4+RSA:+HIGH:+MEDIUM:+LOW:+SSLv2:+EXP:+eNULL # # You can make a self-signed key and cert with; # # openssl req -x509 -newkey rsa:1024 -keyout server-key.pem -out server-cert.pem -days 365 -nodes # CREATE POOL my_apaches POOL my_apaches ADD 10.0.0.10:8080 POOL my_apaches ADD 10.0.0.11:8080 CREATE SERVICE site SET listen = 0.0.0.0:443 SET role = reverse_proxy SET pool = my_apaches SET persist_client = on SET persist_backend = on SET verify_backend = on SET enable_ssl = on SET ssl_key_file = certs/server-key.pem SET ssl_cert_file = certs/server-cert.pem # optionally set the cipher list. the default is "ALL:!LOW:!EXP" SET ssl_cipher_list = ALL:!ADH:!EXPORT56:RC4+RSA:+HIGH:+MEDIUM:+LOW:+SSLv2:+EXP:+eNULL ENABLE site # always good to keep an internal management port open: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt Perlbal-1.80/conf/virtual-hosts.conf0000644000175000017500000000147111503530123017627 0ustar dormandodormando# # This is an example webserver configuration using virtual hosts. # # See doc/config-guide.txt for descriptions of each command (line) # and configuration syntax. # LOAD vhosts CREATE SERVICE site SET role = web_server SET docroot = /var/www/site.com/ SET dirindexing = 1 ENABLE site CREATE SERVICE example SET role = web_server SET docroot = /var/www/example.com/ SET dirindexing = 0 ENABLE example CREATE SERVICE vdemo SET listen = 0.0.0.0:80 SET role = selector SET plugins = vhosts SET persist_client = on VHOST *.site.com = site VHOST *.example.com = example ENABLE vdemo # always good to keep an internal management port open: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt Perlbal-1.80/conf/echoservice.conf0000644000175000017500000000106011503530123017274 0ustar dormandodormando# # This is an example configuration using the EchoService plugin. # # See doc/config-guide.txt for descriptions of each command (line) # and configuration syntax. # LOAD EchoService CREATE SERVICE echo SET listen = 0.0.0.0:7123 SET role = echo ENABLE echo CREATE SERVICE echo_delayed SET listen = 0.0.0.0:7124 SET role = echo SET echo_delay = 3 ENABLE echo_delayed # always good to keep an internal management port open: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt Perlbal-1.80/conf/webserver.conf0000644000175000017500000000074511503530123017012 0ustar dormandodormando# # This is an example webserver configuration. # # See doc/config-guide.txt for descriptions of each command (line) # and configuration syntax. # CREATE SERVICE docs SET listen = 0.0.0.0:80 SET role = web_server SET docroot = /usr/share/doc/ SET dirindexing = 1 SET persist_client = on ENABLE docs # always good to keep an internal management port open: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt Perlbal-1.80/conf/not-modified-plugin.conf0000644000175000017500000000067311503530123020660 0ustar dormandodormandoLOAD vhosts LOAD NotModified # if you have a host that always serves immutable content, this plugin # will reply 304 if client sent any "If-Modified-Since" header. since # if they have SOME copy, it's the correct one. CREATE SERVICE demo SET listen = 0.0.0.0:8001 SET role = selector SET plugins = vhosts, notmodified SET persist_client = true SET demo.notmodified.host_pattern = ^immutable\. ENABLE demo Perlbal-1.80/conf/nodelist.dat0000644000175000017500000000026411503530123016446 0ustar dormandodormando# whitespace and comments allowed 10.1.0.10 # test machine #10.1.0.10:8083 # test machine # can include port numbers, but defaults to 80 if not provided: # 10.1.0.4:80 Perlbal-1.80/conf/load-balancer.conf0000644000175000017500000000235411503530123017470 0ustar dormandodormando# # This is an example reverse configuration doing load balancing. # # See doc/config-guide.txt for descriptions of each command (line) # and configuration syntax. # # this service's nodes are configured via a pool object. if you need # to change them, telnet on in to the management port and you and/or your # scripts can change them on the fly CREATE POOL my_apaches POOL my_apaches ADD 10.0.0.10:8080 POOL my_apaches ADD 10.0.0.11:8080 POOL my_apaches ADD 10.0.0.12 POOL my_apaches ADD 10.0.0.13:8081 CREATE SERVICE balancer SET listen = 0.0.0.0:80 SET role = reverse_proxy SET pool = my_apaches SET persist_client = on SET persist_backend = on SET verify_backend = on ENABLE balancer # this service's nodes are read via a file. the file is checked every # few seconds to see if it changed and automatically picked up. use what # works for you. CREATE POOL dynamic SET nodefile = conf/nodelist.dat CREATE SERVICE balancer2 SET listen = 0.0.0.0:81 SET role = reverse_proxy SET pool = dynamic ENABLE balancer2 # always good to keep an internal management port open: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt Perlbal-1.80/MANIFEST0000644000175000017500000000537711722624722014365 0ustar dormandodormandoCHANGES conf/echoservice.conf conf/load-balancer.conf conf/nodelist.dat conf/not-modified-plugin.conf conf/ssl.conf conf/virtual-hosts.conf conf/webserver.conf contrib/perlbal-check contrib/perlbal-check.yaml CONTRIBUTING devtools/gendocs.pl doc/config-guide.txt doc/hacking/classes.txt doc/hacking/hooks.txt doc/hacking/todo.txt doc/http-versions.txt doc/pool-parameters.txt doc/README doc/reproxying.txt doc/service-parameters.txt lib/Perlbal.pm lib/Perlbal/AIO.pm lib/Perlbal/BackendHTTP.pm lib/Perlbal/Cache.pm lib/Perlbal/ChunkedUploadState.pm lib/Perlbal/ClientHTTP.pm lib/Perlbal/ClientHTTPBase.pm lib/Perlbal/ClientManage.pm lib/Perlbal/ClientProxy.pm lib/Perlbal/CommandContext.pm lib/Perlbal/FAQ.pod lib/Perlbal/Fields.pm lib/Perlbal/HTTPHeaders.pm lib/Perlbal/ManageCommand.pm lib/Perlbal/Manual.pod lib/Perlbal/Manual/Configuration.pod lib/Perlbal/Manual/Contributing.pod lib/Perlbal/Manual/Credits.pod lib/Perlbal/Manual/Debugging.pod lib/Perlbal/Manual/FailOver.pod lib/Perlbal/Manual/HighPriority.pod lib/Perlbal/Manual/Hooks.pod lib/Perlbal/Manual/Install.pod lib/Perlbal/Manual/Internals.pod lib/Perlbal/Manual/LoadBalancer.pod lib/Perlbal/Manual/Logging.pod lib/Perlbal/Manual/Management.pod lib/Perlbal/Manual/Plugins.pod lib/Perlbal/Manual/ReverseProxy.pod lib/Perlbal/Manual/Roles.pod lib/Perlbal/Manual/Selector.pod lib/Perlbal/Manual/WebServer.pod lib/Perlbal/Plugin/AccessControl.pm lib/Perlbal/Plugin/AutoRemoveLeadingDir.pm lib/Perlbal/Plugin/Cgilike.pm lib/Perlbal/Plugin/EchoService.pm lib/Perlbal/Plugin/FlvStreaming.pm lib/Perlbal/Plugin/Highpri.pm lib/Perlbal/Plugin/Include.pm lib/Perlbal/Plugin/LazyCDN.pm lib/Perlbal/Plugin/MaxContentLength.pm lib/Perlbal/Plugin/NotModified.pm lib/Perlbal/Plugin/Palimg.pm lib/Perlbal/Plugin/Queues.pm lib/Perlbal/Plugin/Redirect.pm lib/Perlbal/Plugin/Stats.pm lib/Perlbal/Plugin/Throttle.pm lib/Perlbal/Plugin/Vhosts.pm lib/Perlbal/Plugin/Vpaths.pm lib/Perlbal/Plugin/XFFExtras.pm lib/Perlbal/Pool.pm lib/Perlbal/ReproxyManager.pm lib/Perlbal/Service.pm lib/Perlbal/Socket.pm lib/Perlbal/SocketSSL.pm lib/Perlbal/TCPListener.pm lib/Perlbal/Test.pm lib/Perlbal/Test/WebClient.pm lib/Perlbal/Test/WebServer.pm lib/Perlbal/UploadListener.pm lib/Perlbal/Util.pm Makefile.PL MANIFEST MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) perlbal README t/00-use.t t/10-testharness.t t/12-headers.t t/13-server-tokens.t t/15-webserver.t t/17-webserver-concat.t t/20-put.t t/22-chunked-put.t t/30-reverseproxy.t t/31-realworld.t t/32-pipelining.t t/32-selector.t t/35-reproxy.t t/40-ranges.t t/45-buffereduploads.t t/50-plugins.t t/52-chunked-upload.t t/60-child-httpd.t t/75-plugin-include.t t/76-plugin-redirect.t t/77-plugin-throttle.t t/78-plugin-xffextras.t t/90-accesscontrol.t t/91-fields.t t/99-benchmark-bool.t t/helper/child-httpd.pl Perlbal-1.80/devtools/0000755000175000017500000000000011722625030015050 5ustar dormandodormandoPerlbal-1.80/devtools/gendocs.pl0000755000175000017500000000366011713660634017050 0ustar dormandodormando#!/usr/bin/env perl # use strict; use FindBin; use lib "$FindBin::Bin/../lib"; use Perlbal; my $tunables = Perlbal::Service::autodoc_get_tunables(); my %by_role; while (my ($k, $tun) = each %$tunables) { $by_role{$tun->{check_role}}{$k} = $tun; } my $docs = $FindBin::Bin . "/../doc"; open (H, ">$docs/service-parameters.html") or die "Can't open $docs/service-parameters.html for writing"; print H <Perlbal Service parametersSet via commands of either forms: 
SET <service-name> <param> = <value>
SET <param> = <value>

Note on types: 'bool' values can be set using one of 1, true, yes, on, 0, false, off, or no. 'size' values are in integer bytes, or an integer followed by 'b', 'k', or 'm' (case-insensitive) for bytes, KiB, or MiB.

Note that you can set defaults for all services you create by using the DEFAULT command:

DEFAULT <param> = <value>
HTML foreach my $role ("*", "reverse_proxy", "web_server") { if ($role eq "*") { print H "

For all services:

"; } else { print H "

Only for '$role' services:

"; } print H "\n"; print H "\n"; foreach my $param (sort keys %{$by_role{$role}}) { my $tun = $by_role{$role}{$param}; my $def = $tun->{default}; my $type = $tun->{check_type} || ""; undef $type unless $type && $type =~ /^bool|int|size$/; if ($type eq "bool") { $def = $def ? "true" : "false"; } print H "\n"; } print H "
ParamtypeDefaultDescription
$param$type$def$tun->{des}
\n"; } system("links -dump $docs/service-parameters.html > $docs/service-parameters.txt") and die "Error: links not installed"; unlink "$docs/service-parameters.html"; Perlbal-1.80/perlbal0000755000175000017500000000453611503530123014563 0ustar dormandodormando#!/usr/bin/perl -w # =head1 NAME Perlbal - Reverse-proxy load balancer and webserver =head1 DESCRIPTION For now, see example configuration files in conf/ from the CPAN tarball http://search.cpan.org/dist/Perlbal/ =head1 AUTHORS Brad Fitzpatrick, Mark Smith, =head1 SEE ALSO http://www.danga.com/perlbal/ =head1 COPYRIGHT AND LICENSE Copyright 2004, Danga Interactive, Inc. Copyright 2005-2007, Six Apart, Ltd. You can use and redistribute Perlbal under the same terms as Perl itself. =cut use strict; use warnings; use lib 'lib'; use Perlbal; my $opt_daemonize; my $opt_config; my $opt_help; my $opt_version; usage(1) unless Getopt::Long::GetOptions( 'daemon' => \$opt_daemonize, 'config=s' => \$opt_config, 'help' => \$opt_help, 'version' => \$opt_version, ); my $default_config = "/etc/perlbal/perlbal.conf"; $opt_config = $default_config if ! $opt_config && -e $default_config; usage(0) if $opt_help; sub usage { my $rv = shift; print STDERR <WatchedSockets() > 0) { die "No services or management port configured. Nothing to do. Stopping.\n"; } if ($opt_daemonize) { Perlbal::daemonize(); } else { print "Running.\n"; } exit 0 if Perlbal::run(); exit 1; # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Perlbal-1.80/t/0000755000175000017500000000000011722625030013454 5ustar dormandodormandoPerlbal-1.80/t/91-fields.t0000644000175000017500000000216311713660634015351 0ustar dormandodormandouse strict; use warnings; use Carp; use Test::More 0.94 tests => 6; # last test to print use Hash::Util; my $warn_mocked = "mocked by perlbal, this error should not be raised using Perlbal::Fields"; { no warnings 'redefine'; *Hash::Util::lock_ref_keys = sub { croak $warn_mocked; }; } SKIP: { skip "perl need to be greater than 5.009", 1 if ( $] < 5.009 ); subtest 'before using Perlbal::Fields' => sub { use_ok('Perlbal::CommandContext'); eval { Perlbal::CommandContext->new(); }; like( $@, qr{$warn_mocked}, "use old library" ); }; } my $class = 'Perlbal::Fields'; use_ok( $class, "can load module $class" ); ok( $class->run(), "run method" ); isa_ok( Perlbal::Test::Fields->new(), 'Perlbal::Test::Fields', "can create object" ); use_ok('Perlbal::CommandContext'); isa_ok( Perlbal::CommandContext->new(), 'Perlbal::CommandContext', "can create object" ); done_testing(); 1; package Perlbal::Test::Fields; use fields ( 'headers', 'origcase' ); sub new { my Perlbal::Test::Fields $self = shift; $self = fields::new($self) unless ref $self; return $self; } 1; Perlbal-1.80/t/40-ranges.t0000644000175000017500000000750111503530123015337 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More tests => 35; my ($back_port) = start_webserver(); # setup a simple perlbal that uses the above server my $webport = new_port(); my $dir = tempdir(); my $deadport = new_port(); 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 SET test.connect_ahead = 0 SET test.enable_reproxy = true ENABLE test CREATE SERVICE ws SET ws.role = web_server SET ws.listen = 127.0.0.1:$webport SET ws.docroot = $dir SET ws.dirindexing = 0 SET ws.persist_client = 1 ENABLE ws }; my $msock = start_server($conf); ok($msock, 'perlbal started'); ok(manage("POOL a ADD 127.0.0.1:$back_port"), "backend port added"); my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(1); $wc->http_version('1.0'); # see if a single request works my $resp = $wc->request('status'); ok($resp, 'status response ok'); # make a file on disk, verifying we can get it via disk/URL my $phrase = "foo bar yo this is my content.\n"; my $file_content = $phrase x 1000; open(F, ">$dir/foo.txt"); print F $file_content; close(F); ok(filecontent("$dir/foo.txt") eq $file_content, "file good via disk"); my $hc = Perlbal::Test::WebClient->new; $hc->server("127.0.0.1:$webport"); $hc->keepalive(1); $hc->http_version('1.0'); $resp = $hc->request('foo.txt'); ok($resp && $resp->content eq $file_content, 'file good via network'); # now request some ranges on it..... foreach my $meth (qw(http rp_file rp_url)) { my $ua = { 'http' => $hc, 'rp_file' => $wc, 'rp_url' => $wc, }->{$meth} || die; my $path = { 'http' => "foo.txt", 'rp_file' => "reproxy_file:$dir/foo.txt", 'rp_url' => "reproxy_url:http://127.0.0.1:$webport/foo.txt", }->{$meth} || die; my $resp; my $range; my $send = sub { $range = shift; $resp = $ua->request({ headers => "Range: $range\r\n"}, $path); }; my @aios = ("-"); if ($meth eq "rp_file" || $meth eq "http") { @aios = qw(none ioaio); } foreach my $aio (@aios) { my $setaio = $aio eq "-" ? 1 : manage("SERVER aio_mode = $aio"); SKIP: { skip "can't do AIO mode $aio", 6 unless $setaio; $send->("bytes=0-6"); ok($resp && $resp->content eq "foo bar", "$meth/$aio: range $range"); ok($resp->status_line =~ /^206/, "is partial") or diag(dump_res($resp)); $send->("bytes=" . length($phrase) . "-"); ok($resp && $resp->content eq ($phrase x 999), "$meth/$aio: range $range"); ok($resp->status_line =~ /^206/, "is partial") or diag(dump_res($resp)); $send->("bytes=" . length($file_content) . "-"); ok($resp && $resp->status_line =~ /^416/, "$meth/$aio: can't satisify") or diag(dump_res($resp)); $send->("bytes=5-1"); ok($resp && $resp->status_line =~ /^416/, "$meth/$aio: can't satisify") or diag(dump_res($resp)); } } } # try to reproxy to a list of URLs, where the first one is bogus, and last one is good #ok_reproxy_url_list(); sub ok_reproxy_url_list { my $resp = $wc->request("reproxy_url_multi:$deadport:$webport:/foo.txt"); ok($resp->content eq $file_content, "reproxy URL w/ dead one first"); } sub ok_reproxy_file { my $resp = $wc->request("reproxy_file:$dir/foo.txt"); ok($resp && $resp->content eq $file_content, "reproxy file"); } sub ok_reproxy_url { my $resp = $wc->request("reproxy_url:http://127.0.0.1:$webport/foo.txt"); ok($resp->content eq $file_content, "reproxy URL"); } sub ok_status { my $resp = $wc->request('status'); ok($resp && $resp->content =~ /\bpid\b/, 'status ok'); } 1; Perlbal-1.80/t/15-webserver.t0000644000175000017500000000576311503530123016076 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More tests => 17; require HTTP::Request; require HTTP::Date; 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 HEADER test insert X-Good-Day: 1 HEADER test insert X-Bad-Day: 0 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; } our $last_res; sub get { my $url = shift; my $req = HTTP::Request->new(GET => $url); my $res = $last_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"); # a get with URL parameters ok(get("$url?foo=bar") eq $contents, "GET request"); { my $file_time = (stat($disk_file))[9]; my $req = HTTP::Request->new(GET => $url, [ 'If-Modified-Since' => HTTP::Date::time2str($file_time) ]); my $res = $ua->request($req); is($res->code, 304, "Got not modified"); is($res->header("Content-Length"), undef, "Shouldn't get a Content-Length header"); } set_path("/foo/bar+baz.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 with '+' filename"); # 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"); } # test that index files work { my $dirurl = $url; $dirurl =~ s!/[^/]+?$!/!; manage("SET test.dirindexing = 0"); my $diridx = get($dirurl); like($diridx, qr/Directory listing disabled/, "no dirlist"); manage("SET test.index_files = not_here.txt, nor_here.html, bar.txt"); $diridx = get($dirurl); like($diridx, qr/foo bar baz/, "got the index file"); manage("SET test.index_files = blah.txt"); $diridx = get($dirurl); like($diridx, qr/Directory listing disabled/, "no dirlist again"); } # directory traversal should fail ok(! get("$url/../foo/bar.txt"), "directory traversal"); # files with '..' in the names should succeed { set_path("/foo/foo..123.txt"); write_file(); ok(get($url) eq $contents, "File with .. in name"); } 1; Perlbal-1.80/t/20-put.t0000644000175000017500000000706711713660634014713 0ustar dormandodormando#!/usr/bin/perl use strict; use warnings; use Perlbal::Test; use Test::More 'no_plan'; use Digest::MD5 qw/md5_base64/; 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 %opts = @_; my $req = HTTP::Request->new(PUT => $url); $content = "foo bar baz\n" x 1000; if (exists $opts{content}) { $content = $opts{content} } $req->content($content); if (my $headers = $opts{headers}) { $req->header(@$headers); } 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"); } sub content_md5 { # Digest::MD5 doesn't pad base64 digests, so we have to do it ourselves [ "Content-MD5", md5_base64($_[0]) . '==' ] } # 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"), "min_put = 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(put_file(content => "", headers => [ "Content-Length" => 0 ]), "aio $mode: zero byte file put"); 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 foreach_aio { my $mode = shift; my $path = "tree-$mode/a/b/c/d/foo.txt"; $url = "http://127.0.0.1:$port/$path"; $disk_file = "$dir/$path"; ok(put_file(), "$mode: made deep file"); ok(-f $disk_file, "$mode: 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"); ok(manage("SET test.enable_put = 1")); ok(manage("SET test.enable_md5 = 1")); ok(put_file(), "put re-enabled"); # Content-MD5 checking ok(put_file(content => "!", headers => content_md5('!')), "Content-MD5 OK"); verify_put(); ok(! put_file(content => "?", headers => content_md5('!')), "Content-MD5 rejected"); ok(filecontent($disk_file) ne $content, "verified put failure"); { my @list = (<$disk_file*>); ok(scalar(@list) == 1 && $list[0] eq $disk_file, "no temporary file leftover"); } $content = "!"; verify_put(); ok(manage("SET test.enable_md5 = 0"), "disable MD5 verification"); ok(put_file(content => "?", headers => content_md5('!')), "Content-MD5 NOT rejected"); verify_put(); 1; Perlbal-1.80/t/13-server-tokens.t0000644000175000017500000000257711630514744016713 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More tests => 13; require HTTP::Request; # Build conf files my $dir = tempdir(); my @confs = ( [ new_port() => sub { my $port = shift; qq{ CREATE SERVICE test SET role = web_server SET listen = 127.0.0.1:$port SET docroot = $dir SET server_tokens = on ENABLE test } } ], [ new_port() => sub { my $port = shift; qq{ CREATE SERVICE test SET role = web_server SET listen = 127.0.0.1:$port SET docroot = $dir SET server_tokens = off ENABLE test } } ], ); my $count = 0; foreach my $pair (@confs) { my $port = $pair->[0]; my $conf = $pair->[1]->($port); my $msock = start_server($conf); ok($msock, "manage sock"); my $ua = ua(); ok($ua, "ua"); my $req = HTTP::Request->new( GET => "http://127.0.0.1:$port/" ); my $res = $ua->request($req); ok( $res, 'Got result' ); isa_ok( $res, 'HTTP::Response' ); ok( $res->is_success, 'Result is successful' ); if ( $count++ == 0 ) { # check it's on ok( $res->header('Server'), 'Server header exists' ); is( $res->header('Server'), 'Perlbal' ); } else { # check it's off ok( ! $res->header('Server'), 'Server header missing' ); } } Perlbal-1.80/t/78-plugin-xffextras.t0000644000175000017500000000216611713660634017421 0ustar dormandodormandouse strict; use warnings; use lib 't/lib'; use Perlbal::Test; use Perlbal::Test::WebClient; use Perlbal::Test::WebServer; use Test::More tests => 4; my $perlbal_address = '127.0.0.1'; my $perlbal_port = new_port(); my $web_port = start_webserver(); ok($web_port, 'webserver started'); my $conf = qq{ LOAD XFFExtras CREATE POOL a POOL a ADD 127.0.0.1:$web_port CREATE SERVICE proxy SET role = reverse_proxy SET listen = $perlbal_address:$perlbal_port SET pool = a SET plugins = XFFExtras SET send_backend_port = yes SET send_backend_proto = yes ENABLE proxy }; my $msock = start_server($conf); ok($msock, 'perlbal started'); my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$perlbal_port"); $wc->http_version('1.0'); my $resp = $wc->request("reflect_request_headers"); my $content = $resp->content; like($content, qr/^X-Forwarded-Port: \Q$perlbal_port\E$/mi, "Got an X-Forwarded-Port header that seems reasonable"); like($content, qr/^X-Forwarded-Proto: (?-i:http)$/mi, "Got an X-Forwarded-Proto header that seems reasonable"); Perlbal-1.80/t/99-benchmark-bool.t0000644000175000017500000000464711712141550016775 0ustar dormandodormandouse strict; use warnings; use Test::More 0.94 tests => 5; # last test to print for my $class (qw/Perlbal Perlbal::Service/) { use_ok( $class, "can load module $class" ); } my $class = 'Perlbal::Service'; subtest 'module checking' => sub { isa_ok( $class->new(), $class, "can create object from $class" ); }; my @words = generate_words(1000); subtest 'check sub integrity' => sub { is_deeply( test_optimized(), test_original(), "sub optimized" ); is_deeply( test_hash(), test_original(), "sub hash" ); }; SKIP: { skip "need Benchmark module", 1 unless eval "require Benchmark"; subtest 'benchmark bool sub' => sub { use_ok('Benchmark'); timethese( shift || 100000, { 'void' => sub { map { 1 } @words; }, 'original' => \&test_original, 'optimized' => \&test_optimized, 'hash' => \&test_hash, } ); }; } done_testing(); # helpers sub test_original { map { _bool_original($_) } @words; } sub test_optimized { map { _bool_optimized($_) } @words; } sub test_hash { map { Perlbal::Service::_bool($_) } @words; } sub _bool_original { my $val = shift; return unless defined $val; return 1 if $val =~ /^1|true|on|yes$/i; return 0 if $val =~ /^0|false|off|no$/i; return undef; } { # should use state my $qr_on; my $qr_off; sub _bool_optimized { my $val = shift; return unless defined $val; $qr_on = qr/^1|true|on|yes$/i unless defined $qr_on; $qr_off = qr/^0|false|off|no$/i unless defined $qr_off; return 1 if $val =~ $qr_on; return 0 if $val =~ $qr_off; return undef; } } sub generate_words { my $n = shift || 10; my @words = qw/1 true on yes 0 false off no/; my $reply = []; for ( 1 .. $n ) { my $w = $words[ int rand( scalar @words ) ]; if ( rand(3) > 1 ) { if ( rand(2) > 1 ) { $w = uc($w); } else { my $l = length $w; for my $c ( 1 .. $l ) { next if ( rand(2) > 1 ); substr( $w, $c - 1, 1 ) = uc( getn_substr( $w, $c ) ); } } } push( @$reply, $w ); } return $reply; } sub getn_substr { return substr $_[0], $_[1] - 1, 1; } Perlbal-1.80/t/17-webserver-concat.t0000644000175000017500000000536611503530123017344 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More tests => 20; 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 SET test.enable_concatenate_get = 1 ENABLE test }; my $http = "http://127.0.0.1:$port"; my $msock = start_server($conf); ok($msock, "manage sock"); my $ua = ua(); ok($ua, "ua"); sub set_disk { my ($relpath, $contents) = @_; open(F, ">$dir$relpath") or die "Couldn't open $dir$relpath: $!\n"; print F $contents; close F; } our $last_res; sub get { my $url = shift; my $req = HTTP::Request->new(GET => $url); my $res = $last_res = $ua->request($req); return $res->is_success ? $res->content : undef; } # write two files to disk mkdir "$dir/foo"; mkdir "$dir/foo/bar"; my $chunk1 = "a" x 50 . "\n"; my $chunk2 = "b" x 50 . "\n"; set_disk("/foo/a.txt", $chunk1); set_disk("/foo/b.txt", $chunk2); set_disk("/foo/bar/a.txt", $chunk1); set_disk("/foo/bar/b.txt", $chunk2); # test trailing slash is(get("${http}/foo??a.txt,b.txt"), undef, "need trailing slash"); is($last_res->code, 500, "got 500 without trailing slash"); # test bogus directory is(get("${http}/bogus/??a.txt,b.txt"), undef, "bogus directory"); is($last_res->code, 404, "got 404 for bogus directory"); # test bogus file is(get("${http}/foo/??a.txt,bogus.txt"), undef, "bogus file"); is($last_res->code, 404, "got 404 for bogus file"); is(get("${http}/foo/??a.txt,b.txt"), "$chunk1$chunk2", "basic concat works"); is(get("${http}/foo/??a.txt,bar/b.txt"), "$chunk1$chunk2", "concat w/ directory"); is(get("${http}/foo/??a.txt,a.txt"), "$chunk1$chunk1", "dup concat"); # test that if-modified-since 304 works and w/o a content-length { my $req = HTTP::Request->new(GET => "${http}/foo/??a.txt,bar/b.txt"); my $res = $ua->request($req); ok($res, "got response again"); my $lastmod = $res->header("Last-Modified"); like($lastmod, qr/\bGMT$/, "and it has a last modified"); $req = HTTP::Request->new(GET => "${http}/foo/??a.txt,bar/b.txt"); $req->header("If-Modified-Since" => $lastmod); my $ua_keep = LWP::UserAgent->new(keep_alive => 2); $res = $ua_keep->request($req); ok($res, "got response again"); is($res->code, 304, "the response is a 304"); like($res->header("Last-Modified"), qr/\bGMT$/, "and it has a last modified"); ok(! $res->header("Content-Length"), "No content-length"); like($res->header("Connection"), qr/\bkeep-alive\b/, "and it's keep-alive"); } manage("SET test.enable_concatenate_get = 0"); is(get("${http}/foo/??a.txt,a.txt"), undef, "denied"); is($last_res->code, 403, "got 403"); 1; Perlbal-1.80/t/helper/0000755000175000017500000000000011722625030014733 5ustar dormandodormandoPerlbal-1.80/t/helper/child-httpd.pl0000755000175000017500000000055211503530123017474 0ustar dormandodormando#!/usr/bin/perl use strict; my $req = <>; die "Bogus request" unless $req =~ /^GET (\/\S*) HTTP\/1\.\d/; $| = 1; my $uri = $1; while (<>) { last unless /\S/; } my $response = "You wanted [$uri] and I am pid=$$\n"; #warn "Response from pid $$: [$response]\n"; my $len = length $response; print "HTTP/1.0 200 OK\r\nContent-Length: $len\r\n\r\n$response"; Perlbal-1.80/t/45-buffereduploads.t0000644000175000017500000001366711503530123017251 0ustar dormandodormando#!/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: writes bytes # sleep: sleeps 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: 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; Perlbal-1.80/t/76-plugin-redirect.t0000644000175000017500000000211311503530123017160 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More 'no_plan'; my $port = new_port(); my $conf = qq{ LOAD Redirect LOAD Vhosts CREATE SERVICE ss SET role = selector SET listen = 127.0.0.1:$port SET persist_client = 1 SET plugins = Vhosts VHOST example.com = test ENABLE ss CREATE SERVICE test SET role = web_server SET persist_client = 1 SET plugins = Redirect REDIRECT HOST example.com example.net ENABLE test }; my $msock = start_server($conf); ok($msock, 'perlbal started'); # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$port"); $wc->keepalive(1); $wc->http_version('1.0'); my $resp = $wc->request({ host => "example.com", }, "foo/bar.txt"); # Test lib prepends '/' for me. ok($resp, "Got a response"); is($resp->code, 301, "Redirect has proper code"); like($resp->header("Location"), qr{^http://example.net/foo/bar.txt$}, "Correct redirect response"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); 1; Perlbal-1.80/t/00-use.t0000644000175000017500000000012111503530123014637 0ustar dormandodormando#!/usr/bin/perl -w use strict; use Test::More tests => 1; use Perlbal; ok(1); Perlbal-1.80/t/52-chunked-upload.t0000644000175000017500000001232111503530123016762 0ustar dormandodormando#!/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: writes bytes # sleep: sleeps 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: 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; Perlbal-1.80/t/30-reverseproxy.t0000644000175000017500000001137311503530123016636 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More tests => 28; # 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 SET test.connect_ahead = 0 ENABLE test }; my $msock = start_server($conf); ok($msock, 'perlbal started'); add_all(); # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(0); $wc->http_version('1.0'); ok($wc, 'web client object created'); # see if a single request works my $resp = $wc->request('status'); ok($resp, 'status response ok'); my $pid = pid_of_resp($resp); ok($pid, 'web server functioning'); is($wc->reqdone, 0, "didn't persist to perlbal"); # verify 1 count is(req_count(), 1, 'stats show 1 request'); # persistent is on, so let's do some more and see if they're counting up $wc->keepalive(1); $resp = $wc->request('status'); is(reqnum($resp), 2, "second request"); is($wc->reqdone, 1, "persist to perlbal"); $resp = $wc->request('status'); is(reqnum($resp), 3, "third request"); is($wc->reqdone, 2, "persist to perlbal again"); # verify 3 count is(req_count(), 3, 'stats show 3 requests'); # turn persisent off and see that they're not going up ok(manage("SET test.persist_backend = 0"), "persist backend off"); # do some request to get rid of that perlbal->backend connection (it's # undefined whether disabling backend connections immediately # disconnects them all or not) $resp = $wc->request('status'); # dummy request $resp = $wc->request('status'); is(reqnum($resp), 1, "first request"); # verify 5 count is(req_count(), 5, 'stats show 5 requests'); # make a second webclient now to test multiple requests at once, and # perlbal making multiple backend connections ok(manage("SET test.persist_backend = 1"), "persist backend back on"); # testing that backend persistence works $resp = $wc->request('status'); $pid = pid_of_resp($resp); $resp = $wc->request('status'); ok($pid == pid_of_resp($resp), "used same backend"); # verify 7 count is(req_count(), 7, 'stats show 7 requests'); # multiple parallel backends in operation $resp = $wc->request("subreq:$pb_port"); $pid = pid_of_resp($resp); my $subpid = subpid_of_resp($resp); ok($subpid, "got subpid"); ok($subpid != $pid, "two different backends in use"); # making the web server suggest not to keep the connection alive, see if # perlbal respects it $resp = $wc->request('keepalive:0', 'status'); $pid = pid_of_resp($resp); $resp = $wc->request('keepalive:0', 'status'); ok(pid_of_resp($resp) != $pid, "discarding keep-alive?"); # verify 11 count is(req_count(), 11, 'stats show 11 requests'); ###### ###### verify_backend requests ###### # let's flush existing connections manage("SET test.persist_backend = 0") or die; $resp = $wc->request('status'); # dummy to flush (see above) is(options($resp), 0, "got a backend that didn't do options"); manage("SET test.persist_backend = 1") or die; ok(manage("SET test.verify_backend = 1"), "enabled verify"); $resp = $wc->request('status'); is(options($resp), 1, "got a backend that did an options"); # verify 13 count is(req_count(), 13, 'stats show 13 requests'); $resp = $wc->request({ headers => "Content-Length: -20\r\n" }, "/foo.txt"); is($resp->code, 400, 'Bad request when negative length'); ok($resp->content =~ m/Content-Length < 0/, "Error is descriptive"); sub add_all { foreach (@web_ports) { manage("POOL a ADD 127.0.0.1:$_") or die; } } sub remove_all { foreach (@web_ports) { manage("POOL a REMOVE 127.0.0.1:$_") or die; } } sub flush_pools { remove_all(); add_all(); } sub pid_of_resp { my $resp = shift; return 0 unless $resp && $resp->content =~ /^pid = (\d+)$/m; return $1; } sub subpid_of_resp { my $resp = shift; return 0 unless $resp && $resp->content =~ /^subpid = (\d+)$/m; return $1; } sub reqnum { my $resp = shift; return 0 unless $resp && $resp->content =~ /^reqnum = (\d+)$/m; return $1; } sub options { my $resp = shift; return undef unless $resp && $resp->content =~ /^options = (\d+)$/m; return $1; } sub req_count { my $msock = msock(); print $msock "nodes\r\n"; my $ct = 0; while (<$msock>) { last if /^\./; next unless /\srequests\s(\d+)/; $ct += $1; } return $ct; } 1; Perlbal-1.80/t/32-selector.t0000644000175000017500000001076311503530123015705 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More tests => 38; # option setup my $start_servers = 2; # 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 $dir = tempdir(); my $pb_port = new_port(); my $conf = qq{ LOAD Vhosts CREATE POOL a CREATE SERVICE ss SET ss.listen = 127.0.0.1:$pb_port SET ss.role = selector SET ss.plugins = vhosts SET ss.persist_client = on VHOST ss proxy = pr VHOST ss webserver = ws VHOST ss *.webserver = ws VHOST ss manage = mgmt ENABLE ss CREATE SERVICE pr SET pr.role = reverse_proxy SET pr.persist_client = 1 SET pr.persist_backend = 1 SET pr.pool = a SET pr.connect_ahead = 0 ENABLE pr CREATE SERVICE ws SET ws.role = web_server SET ws.docroot = $dir SET ws.dirindexing = 0 SET ws.persist_client = 1 SET ws.enable_put = 1 SET ws.enable_delete = 1 ENABLE ws }; my $msock = start_server($conf); ok($msock, 'perlbal started'); foreach (@web_ports) { manage("POOL a ADD 127.0.0.1:$_") or die; } # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(1); $wc->http_version('1.0'); my $resp; # see if a single request works okay_status(); is($wc->reqdone, 1, "one done"); # put a file my $file_content = "foo bar yo this is my content.\n" x 1000; $resp = $wc->request({ method => "PUT", content => $file_content, host => "webserver", }, 'foo.txt'); ok($resp && $resp->code =~ /^2\d\d$/, "Good PUT"); is($wc->reqdone, 2, "two done"); # see if it made it ok(filecontent("$dir/foo.txt") eq $file_content, "file good via disk"); okay_network(); is($wc->reqdone, 3, "three done"); # try a post my $blob = "x bar yo yo yeah\r\n\r\n" x 5000; my $bloblen = length $blob; $resp = $wc->request({ method => "POST", content => $blob, host => "proxy", }, 'status'); ok($resp && $resp->content =~ /^method = POST$/m && $resp->content =~ /^length = $bloblen$/m, "proxy post"); is($wc->reqdone, 4, "four done"); okay_network(); is($wc->reqdone, 5, "five done"); okay_status(); is($wc->reqdone, 6, "six done"); # test that persist_client is based on the selector service, not the selected service ok(manage("SET pr.persist_client = 0"), "pr.persist_client off"); okay_status(); is($wc->reqdone, 7, "seven done"); okay_status(); is($wc->reqdone, 8, "eight done"); ok(manage("SET ss.persist_client = 0"), "ss.persist_client off"); okay_status(); is($wc->reqdone, 0, "zero done"); ok(manage("SET ss.persist_client = 1"), "ss.persist_client on"); okay_status(); is($wc->reqdone, 1, "one done"); ok(manage("SET pr.persist_client = 1"), "pr.persist_client on"); # test the vhost matching $resp = $wc->request({ host => "foo.proxy" }, 'status'); ok($resp && $resp->code =~ /^[45]/, "foo.proxy - bad"); $resp = $wc->request({ host => "foo.webserver" }, 'foo.txt'); ok($resp && $resp->code =~ /^2/, "foo.webserver - good") or diag(dump_res($resp)); $resp = $wc->request({ host => "foo.bar.webserver" }, 'foo.txt'); ok($resp && $resp->code =~ /^2/, "foo.bar.webserver - good"); $resp = $wc->request({ host => "bob" }, 'foo.txt'); ok($resp && $resp->code =~ /^[45]/, "bob - bad"); ok(manage("VHOST ss * = ws"), "enabling a default"); $resp = $wc->request({ host => "bob" }, 'foo.txt'); ok($resp && $resp->code =~ /^2/, "bob - good"); # test sending a request to a management service $resp = $wc->request({ host => "manage" }, 'foo'); ok($resp && $resp->code =~ /^5/, "mapping to invalid service"); # test some management commands (quiet_failure makes the test framework not warn when # these commands fail, since we expect them to) ok(! manage("VHOST ss * ws", quiet_failure => 1), "missing equals"); ok(! manage("VHOST bad_service * = ws", quiet_failure => 1), "bad service"); ok(! manage("VHOST ss *!sdfsdf = ws", quiet_failure => 1), "bad hostname"); ok(! manage("VHOST ss * = ws!!sdf", quiet_failure => 1), "bad target"); sub okay_status { my $resp = $wc->request({ host => "proxy" }, 'status'); ok($resp && $resp->content =~ /\bpid\b/, 'status response ok') or diag(dump_res($resp)); } sub okay_network { my $resp = $wc->request({ host => "webserver" }, 'foo.txt'); ok($resp && $resp->content eq $file_content, 'file good via network') or diag(dump_res($resp)); } 1; Perlbal-1.80/t/22-chunked-put.t0000644000175000017500000001142611503530123016310 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use IO::Socket::INET; 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 $contentlen = 0; my $written_content = ""; sub buffer_file_exists { -e $disk_file; } # cmds can be: # write: writes bytes # sleep: sleeps 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: 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; $contentlen = 0; $written_content = ""; my $hdr = "PUT /foo.txt 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 ($writelen) { diag("Writing: $writelen"); die "Too long" if $writelen > $remain; my $buf = chr(int(rand(26)) + 65) x $writelen; # update what we'll be checking for later, $contentlen += $writelen; $written_content .= $buf; $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: $!, we had finished $off of $bufsize" 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"; } } sub delete_file { my $req = HTTP::Request->new(DELETE => $url); my $res = $ua->request($req); return $res->is_success; } sub verify_put { open(my $fh, $disk_file) or die; my $slurp = do { local $/; <$fh>; }; ok(-s $disk_file == $contentlen && $slurp eq $written_content, "verified put"); } # 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 { verify_put(); }, ); 1; Perlbal-1.80/t/50-plugins.t0000644000175000017500000000037211712163114015545 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal; use Test::More tests => 7; my @plugins = qw(Highpri Palimg Queues Stats Vhosts MaxContentLength Throttle); foreach my $plugin (@plugins) { require_ok("Perlbal::Plugin::$plugin"); } Perlbal-1.80/t/32-pipelining.t0000644000175000017500000000562711503530123016226 0ustar dormandodormando#!/usr/bin/perl # # For now we don't support pipelining, so these tests verify we handle it # properly, notably not poisoning the backend by injecting two when we only # know of one, and also dealing okay with POSTs with an extra \r\n, which # happen in the real world, without disconnecting those users thinking # they're bogus-pipeline-flooding us. # use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More tests => 12; require HTTP::Request; my $port = new_port(); my $dir = tempdir(); # setup a few web servers that we can work with my $start_servers = 1; # web servers to start 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'); my $conf = qq{ CREATE POOL a CREATE SERVICE test SET test.role = reverse_proxy SET test.listen = 127.0.0.1:$port SET test.persist_client = 1 SET test.persist_backend = 1 SET test.pool = a SET test.connect_ahead = 0 ENABLE test }; my $http = "http://127.0.0.1:$port"; my $msock = start_server($conf); ok($msock, "manage sock"); add_all(); my $sock; my $get_sock = sub { return IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port") or die "Failed to connect to perlbal"; }; $sock = $get_sock->(); print $sock "POST /sleep:0.2,status HTTP/1.0\r\nContent-Length: 10\r\n\r\nfoo=56789a"; like(scalar <$sock>, qr/200 OK/, "200 OK on post w/ correct len"); $sock = $get_sock->(); print $sock "POST /sleep:0.2,status HTTP/1.0\r\nContent-Length: 10\r\n\r\nfoo=56789a\r\n"; like(scalar <$sock>, qr/200 OK/, "200 OK on post w/ extra rn not in length"); # test that signal sending works { my $gotsig = 0; local $SIG{USR1} = sub { $gotsig = 1; }; $sock = $get_sock->(); print $sock "GET /kill:$$:USR1,status HTTP/1.0\r\n\r\n"; like(scalar <$sock>, qr/200 OK/, "single GET okay"); ok($gotsig, "got signal"); } # check that somebody can't sneak extra request to backend w/ both \r\n and nothing in between requests foreach my $sep ("\r\n", "") { diag("separator length " . length($sep)); my $gotsig = 0; local $SIG{USR1} = sub { $gotsig = 1; }; $sock = $get_sock->(); print $sock "POST /sleep:0.5,status HTTP/1.0\r\nConnection: keep-alive\r\nContent-Length: 10\r\n\r\nfoo=569789a${sep}GET /kill:$$:USR1,status HTTP/1.0\r\n\r\n"; like(scalar <$sock>, qr/200 OK/, "200 to POST w/ pipelined GET after"); select undef, undef, undef, 0.25; ok(!$gotsig, "didn't get signal from GET after POST"); } $sock = $get_sock->(); print $sock "GET /status HTTP/1.0\r\n\r\n"; like(scalar <$sock>, qr/200 OK/, "single GET okay"); $sock = $get_sock->(); print $sock "GET /status HTTP/1.0\r\n\r\nGET /status HTTP/1.0\r\n\r\n"; like(scalar <$sock>, qr/\b400\b/, "pipelined when not expecting it"); sub add_all { foreach (@web_ports) { manage("POOL a ADD 127.0.0.1:$_") or die; } } 1; Perlbal-1.80/t/12-headers.t0000644000175000017500000000244611503530123015475 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More 'no_plan'; use Perlbal; use Perlbal::HTTPHeaders; # classes we will be testing my @classes = ('Perlbal::HTTPHeaders'); if (eval "use Perlbal::XS::HTTPHeaders 0.20; 1;") { push @classes, $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"); is_deeply([sort map {lc} @{ $obj->headers_list }], [qw/ another header something /], 'headers_list'); } 1; Perlbal-1.80/t/77-plugin-throttle.t0000644000175000017500000000567711712163114017253 0ustar dormandodormandouse strict; use warnings; use lib 't/lib'; use IO::Select; use Perlbal::Test; use Perlbal::Test::WebClient; use Perlbal::Test::WebServer; use Time::HiRes 'time'; use Test::More tests => 2; SKIP: { skip 'TODO', 2; my $perlbal_port = new_port(); my $web_port = start_webserver(); ok($web_port, 'webserver started'); my $conf = qq{ LOAD Throttle CREATE POOL a POOL a ADD 127.0.0.1:$web_port CREATE SERVICE proxy SET role = reverse_proxy SET listen = 127.0.0.1:$perlbal_port SET pool = a SET initial_delay = 1 SET max_delay = 8 SET log_events=all SET plugins = Throttle ENABLE proxy }; my $msock = start_server($conf); ok($msock, 'perlbal started'); for my $n (1 .. 5) { my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$perlbal_port"); $wc->http_version('1.0'); my $start = time; my $resp = $wc->request({ host => "example.com", }, "foo/bar.txt"); my $end = time; printf "req $n took %.2fs\n", $end - $start; #ok($resp, "got a response"); } #print $msock "SET whitelist_file = t/helper/whitelist.txt"; #print $msock "SET blacklist_file = t/helper/blacklist.txt"; # # #is($resp->code, 200, "response code correct"); # #my @readable = $select->can_read(0.1); #if (ok(scalar(@readable), 'syslog got messages')) { # my @msgs = <$syslogd>; # if (is(scalar(@msgs), 7, 'syslog got right number of messages')) { # like($msgs[0], qr/^<173>.*localhost explicit\[\d+\]: registering TestPlugin$/, 'logged Registering'); # like($msgs[1], qr/^<174>.*localhost explicit\[\d+\]: info message in plugin$/, 'logged info message'); # like($msgs[2], qr/^<171>.*localhost explicit\[\d+\]: error message in plugin$/, 'logged error message'); # like($msgs[3], qr/^<173>.*localhost explicit\[\d+\]: printing to stdout$/, 'logged via STDOUT'); # like($msgs[4], qr/^<173>.*localhost explicit\[\d+\]: printing to stderr$/, 'logged via STDERR'); # like($msgs[5], qr/^<174>.*localhost explicit\[\d+\]: beginning run$/, 'captured internal message'); # like($msgs[6], qr/^<173>.*localhost explicit\[\d+\]: handling request in TestPlugin$/, 'logged in request'); # } #} #my $syslog_port = new_port(); #use IO::Socket::INET; #my $syslogd = IO::Socket::INET->new( # Proto => 'udp', # Type => SOCK_DGRAM, # LocalHost => 'localhost', # LocalPort => $syslog_port, # Blocking => 0, # Reuse => 1, #) or die "failed to listen on udp $syslog_port: $!"; #my $select = IO::Select->new($syslogd); } 1; __END__ =head1 TODO * Throttling * Banning * Logging * Memcached/local * Filters * White/blacklist * Configs: default_action whitelist_file blacklist_file blacklist_action throttle_threshold_seconds initial_delay max_delay max_concurrent path_regex method_regex log_only memcached_servers memcached_async_clients instance_name ban_threshold ban_expiration log_events =cut Perlbal-1.80/t/60-child-httpd.t0000644000175000017500000000210111503530123016255 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More; use FindBin qw($Bin); unless ($ENV{PERLBAL_TEST_ALPHA}) { plan skip_all => 'Alpha feature; test skipped without $ENV{PERLBAL_TEST_ALPHA}'; exit 0; } else { plan tests => 4; } # setup a simple perlbal that uses the above server my $pb_port = new_port(); my $conf = qq{ 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.connect_ahead = 0 SET test.server_process = $Bin/helper/child-httpd.pl ENABLE test }; my $msock = start_server($conf); ok($msock, 'perlbal started'); # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(0); $wc->http_version('1.0'); ok($wc, 'web client object created'); # see if a single request works my $resp = $wc->request('status'); ok($resp, 'status response ok'); like($resp->content, qr/and I am pid=/, "got response from child process"); 1; Perlbal-1.80/t/90-accesscontrol.t0000644000175000017500000000406211630514744016742 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use IO::Socket::INET; use HTTP::Request; use Test::More; BEGIN { eval "require Net::Netmask" ? plan 'no_plan' : plan skip_all => 'Net::Netmask not installed'; } my $port = new_port(); my $dir = tempdir(); my $conf = qq{ SERVER aio_mode = none LOAD AccessControl CREATE SERVICE test SET test.role = web_server SET test.plugins = AccessControl SET test.listen = 127.0.0.1:$port SET test.docroot = $dir SET test.persist_client = 1 SET test.AccessControl.use_observed_ip = 1 ENABLE test }; my $msock = start_server($conf); { my $filename = "$dir/foo.txt"; open my $fh, ">", $filename; print $fh "ooblie\n"; close $fh; ok(-e $filename, "File was written properly"); } my $ua = ua(); ok($ua, "UA object defined"); ok(manage("USE test"), "Manage context switch success"); sub check { my $url = "http://127.0.0.1:$port/foo.txt"; my $req = HTTP::Request->new(GET => $url, @_); my $res = $ua->request($req); return $res->is_success; } ok(check(), "Initial request succeeds"); ok(manage("ACCESS deny ip 127.0.0.1"), "ACCESS deny was set properly"); ok(!check(), "Denied"); ok(!check(["X-Forwarded-For" => "1.1.1.1"]), "Denied with XFF header"); ok(manage("SET always_trusted = 1"), "Turning always trusted on"); ok(!check(), "Denied"); ok(check(["X-Forwarded-For" => "1.1.1.1"]), "Allowed with XFF header"); ok(manage("SET always_trusted = 0"), "Turning always trusted off again"); ok(manage("SET trusted_upstream_proxies = 127.0.0.1"), "Turning trusted upstream proxies on for 127.0.0.1"); ok(!check(), "Denied"); ok(check(["X-Forwarded-For" => "1.1.1.1"]), "Allowed with XFF header"); ok(manage("SET trusted_upstream_proxies = 10.0.0.0/24, 127.0.0.1"), "Turning trusted upstream proxies on for multiple netmasks"); ok(!check(), "Denied"); ok(check(["X-Forwarded-For" => "1.1.1.1"]), "Allowed with XFF header"); ok(manage("SET test.AccessControl.use_observed_ip = 0"), "Turning off observed IP"); ok(!check(["X-Forwarded-For" => "1.1.1.1"]), "Denied with XFF header"); Perlbal-1.80/t/35-reproxy.t0000644000175000017500000001440411503530123015574 0ustar dormandodormando#!/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 = 2; # 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 $webport = new_port(); my $dir = tempdir(); my $deadport = new_port(); 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 SET test.connect_ahead = 0 SET test.enable_reproxy = 1 SET test.reproxy_cache_maxsize = 150 ENABLE test CREATE SERVICE ws SET ws.role = web_server SET ws.listen = 127.0.0.1:$webport SET ws.docroot = $dir SET ws.dirindexing = 0 SET ws.persist_client = 1 ENABLE ws }; my $msock = start_server($conf); ok($msock, 'perlbal started'); add_all(); # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(1); $wc->http_version('1.0'); # see if a single request works my $resp = $wc->request('status'); ok($resp, 'status response ok'); # make a file on disk, verifying we can get it via disk/URL my $file_content = "foo bar yo this is my content.\n" x 1000; open(F, ">$dir/foo.txt"); print F $file_content; close(F); ok(filecontent("$dir/foo.txt") eq $file_content, "file good via disk"); { my $wc2 = Perlbal::Test::WebClient->new; $wc2->server("127.0.0.1:$webport"); $wc2->keepalive(1); $wc2->http_version('1.0'); $resp = $wc2->request('foo.txt'); ok($resp && $resp->content eq $file_content, 'file good via network'); } # try to get that file, via internal file redirect ok_reproxy_file(); ok_reproxy_file(); ok($wc->reqdone >= 2, "2 on same conn"); # reproxy URL support ok_reproxy_url(); ok_reproxy_url(); ok($wc->reqdone >= 4, "4 on same conn"); # reproxy URL support, w/ 204s from backend ok_reproxy_url_204(); ok_reproxy_url_204(); # reproxy cache support { my $sig_counter = 0; local $SIG{USR1} = sub { $sig_counter++ }; is($sig_counter, 0, "Prior to first hit, counter should be zero."); ok_reproxy_url_cached("One"); ok_reproxy_url_cached_ims("One"); is($sig_counter, 1, "First hit to populate the cache."); ok_reproxy_url_cached("Two"); ok_reproxy_url_cached_ims("Two"); is($sig_counter, 1, "Second hit should be cached."); sleep 2; is($sig_counter, 1, "Prior to third hit, counter should still be 1."); ok_reproxy_url_cached("Three"); ok_reproxy_url_cached_ims("Three"); is($sig_counter, 2, "Third hit isn't cached, now 2."); ok_reproxy_url_cached("Four"); ok_reproxy_url_cached_ims("Four"); is($sig_counter, 2, "Forth hit should be cached again, still 2."); } # back and forth every combo # FROM / TO: status file url # status X X X # file X X X # url X X X foreach_aio { my $mode = shift; ok_status(); ok_status(); ok_reproxy_file(); ok_reproxy_url(); ok_status(); ok_reproxy_url(); ok_reproxy_url(); ok_reproxy_file(); ok_reproxy_file(); ok_reproxy_url(); ok_reproxy_file(); ok_status(); ok($wc->reqdone >= 12, "AIO mode $mode: 9 transitions"); }; # try to reproxy to a list of URLs, where the first one is bogus, and last one is good ok_reproxy_url_list(); { my $resp = $wc->request("reproxy_url:http://127.0.0.1:$webport/bar.txt http://127.0.0.1:$webport/foo.txt"); ok($resp->content eq $file_content, "reproxy URL w/ 404 one first"); } # responses to HEAD requests should not have a body { $wc->keepalive(0); my $resp = $wc->request({ method => "HEAD", }, "reproxy_url:http://127.0.0.1:$webport/foo.txt"); ok($resp && $resp->content eq '', "no response body when req method is HEAD"); $wc->keepalive(1); } my $lm; sub ok_reproxy_url_cached { my $resp = $wc->request("reproxy_url_cached:1:http://127.0.0.1:$webport/foo.txt"); ok($resp && $resp->content eq $file_content, "reproxy with cache: $_[0]"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); $lm = $resp->header("Last-Modified"); } sub ok_reproxy_url_cached_ims { die "Last-Modified hasn't been set yet" unless defined $lm; my $resp = $wc->request({ headers => "If-Modified-Since: $lm\r\n", }, "reproxy_url_cached:1:http://127.0.0.1:$webport/foo.txt"); ok($resp, "Got a response"); is($resp->code, 304, "reproxy with cache ims, got 304 correctly: $_[0]"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); } sub ok_reproxy_url_list { my $resp = $wc->request("reproxy_url_multi:$deadport:$webport:/foo.txt"); ok($resp->content eq $file_content, "reproxy URL w/ dead one first"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); } sub ok_reproxy_file { my $resp = $wc->request("reproxy_file:$dir/foo.txt"); ok($resp && $resp->content eq $file_content, "reproxy file"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); } sub ok_reproxy_url { my $resp = $wc->request("reproxy_url:http://127.0.0.1:$webport/foo.txt"); ok($resp->content eq $file_content, "reproxy URL") or diag(dump_res($resp)); is($resp->code, 200, "response code is 200"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); } sub ok_reproxy_url_204 { my $resp = $wc->request("reproxy_url204:http://127.0.0.1:$webport/foo.txt"); ok($resp->content eq $file_content, "reproxy URL") or diag(dump_res($resp)); is($resp->code, 200, "204 response code is 200"); like($resp->header("Connection"), qr/Keep-Alive/i, "... and keep-alives are on"); } sub ok_status { my $resp = $wc->request('status'); ok($resp && $resp->content =~ /\bpid\b/, 'status ok'); } sub add_all { foreach (@web_ports) { manage("POOL a ADD 127.0.0.1:$_") or die; } } sub remove_all { foreach (@web_ports) { manage("POOL a REMOVE 127.0.0.1:$_") or die; } } sub flush_pools { remove_all(); add_all(); } 1; Perlbal-1.80/t/10-testharness.t0000644000175000017500000000017111503530123016414 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More 'no_plan'; my $msock = start_server(""); ok($msock); 1; Perlbal-1.80/t/75-plugin-include.t0000644000175000017500000000171211503530123017005 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Test::More tests => 8; require HTTP::Request; require HTTP::Date; my $dir = tempdir(); my $msock = start_server(); ok($msock, "manage sock"); ok(manage("LOAD Include"), "load include"); # Build conf files for ('a' .. 'c') { my $port = new_port(); my $conf = qq{ 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_$_ }; open(F, ">$dir/$_.conf") or die "Couldn't open $dir/$_.conf: $!\n"; print F $conf; close F; } ok(manage("INCLUDE = $dir/a.conf"), "include single"); ok(manage("INCLUDE = $dir/b* $dir/c*"), "include multi"); ok(! manage("INCLUDE = $dir/d.conf", quiet_failure => 1), "error on nonexistent conf"); my $s_output = manage_multi("show SERVICE"); for ('a' .. 'c') { like($s_output, qr/^test_$_ .+ ENABLED/m, "test_$_ loaded"); } 1; Perlbal-1.80/t/31-realworld.t0000644000175000017500000001030711503530123016051 0ustar dormandodormando#!/usr/bin/perl use strict; use Perlbal::Test; use Perlbal::Test::WebServer; use Perlbal::Test::WebClient; use Test::More tests => 157; # 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 $pb_ss_port = new_port(); my $pb_ss2_port = new_port(); my $buffer_dir = tempdir(); 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 SET test.connect_ahead = 0 SET buffer_uploads_path = $buffer_dir SET buffer_uploads = off SET buffer_upload_threshold_size = 1 ENABLE test LOAD Vhosts CREATE SERVICE ss SET role = selector SET listen = 127.0.0.1:$pb_ss_port SET persist_client = on SET plugins = vhosts VHOST * = test ENABLE ss CREATE SERVICE ss2 SET role = selector SET listen = 127.0.0.1:$pb_ss2_port SET persist_client = on SET plugins = vhosts VHOST * = ss ENABLE ss2 }; my $msock = start_server($conf); ok($msock, 'perlbal started'); my $overall_count = 1; add_all(); { # make first web client my $wc = Perlbal::Test::WebClient->new; $wc->server("127.0.0.1:$pb_port"); $wc->keepalive(0); $wc->http_version('1.0'); ok($wc, 'web client object created'); # see if a single request works my $resp = $wc->request('status'); ok($resp, 'status response ok'); my $pid = pid_of_resp($resp); ok($pid, 'web server functioning'); is($wc->reqdone, 0, "didn't persist to perlbal"); is(reqnum($resp), $overall_count++, "Overall request count is correct"); } my @combinations = ( regular => "127.0.0.1:$pb_port", selector => "127.0.0.1:$pb_ss_port", selector2 => "127.0.0.1:$pb_ss2_port", ); while (@combinations) { die "Uneven list of combinations" if @combinations % 2; my $dport = shift @combinations; my $wc = Perlbal::Test::WebClient->new; $wc->http_version('1.0'); $wc->server(shift @combinations); $wc->keepalive(1); my $ct = 0; for my $type (qw(plain buffer_to_memory buffer_to_disk)) { if ($type eq "plain") { manage("SET test.buffer_backend_connect = 0") or die; manage("SET test.buffer_uploads = off") or die; } elsif ($type eq "buffer_to_memory") { manage("SET test.buffer_uploads = off") or die; ok(manage("SET test.buffer_backend_connect = 250000"), "turned on buffering to memory"); } elsif ($type eq "buffer_to_disk") { ok(manage("SET test.buffer_uploads = on"), "turned on buffering to disk"); } for my $extra_rn (0, 1) { for my $post_header_pause (0, 0.75) { for my $n (1..2) { $ct++; my $resp = $wc->request({ extra_rn => $extra_rn, method => "POST", content => "foo=bar", post_header_pause => $post_header_pause }, 'status'); my $info = "$dport: type=$type, extra_rn=$extra_rn, pause=$post_header_pause, n=$n: good POST"; is(reqnum($resp), $overall_count++, "Overall request count is correct: $info"); is($wc->reqdone, $ct, "persisted to perlbal"); } } } } } sub add_all { foreach (@web_ports) { manage("POOL a ADD 127.0.0.1:$_") or die; } } sub pid_of_resp { my $resp = shift; return 0 unless $resp && $resp->content =~ /^pid = (\d+)$/m; return $1; } sub subpid_of_resp { my $resp = shift; return 0 unless $resp && $resp->content =~ /^subpid = (\d+)$/m; return $1; } sub reqnum { my $resp = shift; return 0 unless $resp && $resp->content =~ /^reqnum = (\d+)$/m; return $1; } sub options { my $resp = shift; return undef unless $resp && $resp->content =~ /^options = (\d+)$/m; return $1; } 1; # vim: filetype=perl Perlbal-1.80/README0000644000175000017500000001622011516736365014111 0ustar dormandodormando Perlbal Copyright 2004, Danga Interactive, Inc. Copyright 2005-2010, Six Apart, Ltd. You can use and redistribute Perlbal under the same terms as Perl itself. http://www.danga.com/perlbal/ INSTALLATION ------------ If you have CPAN installed you can install Perlbal from the command line: $ cpan Perlbal See Perlbal::Manual::Install for further information on installing Perlbal, including instructions for specific operating systems and some troubleshooting (the file lives under lib/Perlbal/Manual/Install.pod, it is recommended that you read it using perldoc). DESCRIPTION ----------- Perlbal is a Perl-based reverse proxy load balancer and web server. It processes hundreds of millions of requests a day just for LiveJournal, TypePad and dozens of other high-traffic websites. Perlbal is a single-threaded event-based server supporting HTTP load balancing, web serving, and a mix of the two (see below). Almost everything in Perlbal can be configured or reconfigured on the fly without needing to restart the software (see Perlbal::Manual::Management). In this file you'll find: * GENERAL FEATURES * PERFORMANCE * STATISTICS AND MONITORING * PLUGINS (EXTENSIBILITY) * FURTHER DOCUMENTATION * SUPPORT * CONTRIBUTING GENERAL FEATURES ---------------- Perlbal has many features; this is just a short list of some of them: Role: Reverse Proxy * Maintains pool of connected backend connections to reduce turnover * Gets list of nodes either from asynchronously monitored node file, or from in-server pool objects which you can add/remove nodes from using the management interface * Intelligent load balancing based on what backend connections are free for a new request. No unreliable "weighting" numbers required * Can verify (using a quick OPTIONS request) that a backend connection is talking to a webserver and not just the kernel's listen queue before sending client requests at it. Lower latency for the client * Has a high priority queue for sending requests through to backends quickly o Uses cookies to determine if a request should go to fast queue (configurable) o Highpri (high priority) plugin supports making requests high priority by URI or Host o Can specify a relief level to let low priority requests through to prevent starvation * Can allow X-Forwarded-For (and similar) headers from client based on client IP * Configurable header management before sending request to backend * Internal redirection to file or URL(s) o Big one for us; a backend can instruct Perlbal to fetch the user's data from a completely separate server and port and URL, 100% transparent to the user o Can actually give Perlbal a list of URLs to try. Perlbal will find one that's alive. Again, the end user sees no redirects happening o Can also redirect to a local file, which Perlbal will serve non-blocking. See webserver mode below * Persistent client connections (configurable) * Persistent backend connections (shared by multiple clients; no "backend waste") Role: Web Server * Listen on a port, share from a directory * Directory indexing * Byte range support (clients can resume downloads) * Can have directory index requests fall back to index file list o I.e., requests for /foo/ go to /foo/index.html instead o Multiple index files supported, tries one at a time until it finds one * Persistent client connections (configurable) * Almost all disk operations are done asynchronously as to not stall the event loop * Configurable support for storing files (PUT, DELETE support) PERFORMANCE ------------- * Great performance "out-of-the-box" (for both small and large sites) * 100% asynchronous in all the recommended use cases * Lightweight * HTTP Header processing (optionally) done in C with Perlbal::XS::HTTPHeaders for maximum performance * Event-based using epoll or kqueue to avoid the scalability problems of not-so-modern systems STATISTICS AND MONITORING ------------------------- Perlbal's management interface provides extremely detailed and powerful statistics in addition to runtime configuration. For example: * CPU usage (user, system) * Total requests served across all services * Requests service by individual backends * Perlbal's uptime * All connected sockets (and tons of info about each) * Outstanding connections to backends * Backends that have recently failed verification * Pending backend connections by service * Total of all socket states by socket type * Size (in seconds and number of connections) of all queues * State of reproxy engine (queued requests, outstanding requests, backends) * Loaded plugins per service (All statistics are in machine readable form, easy to parse and write scripts that check on the status of Perlbal) PLUGINS (EXTENSIBILITY) ----------------------- Perlbal supports the concept of having per-service (and global) plugins that can add functionality or override many parts of request handling and behavior. There are many custom plugins that send new headers to the backends, promote requests to the fast queue, maintain more detailed statistics, do image header manipulation, and more. Writing your own plugins is also easy. For more information on how plugins work, and a list of known plugins see Perlbal::Manual::Plugins. You may also find them easily on CPAN. FURTHER DOCUMENTATION --------------------- Perlbal's documentation is split into several sections under Perlbal::Manual::*. Perlbal::Manual provides the index for the manual: perldoc Perlbal::Manual Individual sections can be viewed in the same manner: perldoc Perlbal::Manual::Configuration perldoc Perlbal::Manual::LoadBalancer perldoc Perlbal::Manual::Plugins If you're interested in the internals of the Perlbal: perldoc Perlbal::Manual::Internals The documentation is relatively new (December 2010) and was mostly written or gathered by Bruno Martins and José Castro under a TPF grant. You can read more about it at http://7eip.sl.pt and http://4hw3.sl.pt. SUPPORT ------------- Feel free to ask us questions on the mailing list: http://groups.google.com/group/perlbal There are also the old Perlbal List Archives for postings until June 2008: http://lists.danga.com/pipermail/perlbal/ CONTRIBUTING ------------- You may find information on how to contribute under Perlbal::Manual::Contributing. The source code currently resides in https://github.com/perlbal/Perlbal AUTHOR ------------- Perlbal was originally written by Brad Fitzpatrick and counts with the help and contributions from many other people. See Perlbal::Manual::Credits for details. COPYRIGHT ------------- Copyright 2004, Danga Interactive, Inc. Copyright 2005-2010, Six Apart, Ltd. You can use and redistribute Perlbal under the same terms as Perl itself. Perlbal-1.80/contrib/0000755000175000017500000000000011722625030014651 5ustar dormandodormandoPerlbal-1.80/contrib/perlbal-check.yaml0000644000175000017500000000044311520230210020216 0ustar dormandodormandositedefault: firstcluster firstcluster: boxone: 10.0.0.11:8000 boxtwo: 10.0.0.12:8000 secondcluster: boxthree: 10.0.0.13:8000 boxfour: 10.0.0.14:8000 thirdcluster: boxfive: 10.0.0.15:8000 boxsix: 10.0.0.16:8000 twoclusters: - firstcluster - secondcluster Perlbal-1.80/contrib/perlbal-check0000755000175000017500000002757611713660634017325 0ustar dormandodormando#!/usr/bin/perl =head1 NAME perlbal-check - monitor traffic on one or more perlbal instances =head1 DESCRIPTION Allows you to monitor potentially aggregated queues, and parse the output of "socks" into some useful formats; top urls, top clients, etc. =head1 AUTHORS additions by Abe Hassan additions by Kallen rewritten and expanded by dormando =head1 SEE ALSO http://www.danga.com/perlbal/ =head1 COPYRIGHT AND LICENSE Copyright 2008-2011, Six Apart, Ltd. You can use and redistribute Perlbal under the same terms as Perl itself. =cut use strict; use warnings; use IO::Socket::INET; use Getopt::Long; use Data::Dumper qw(Dumper); use YAML qw(LoadFile); use List::Util qw(max); $| = 1; # determine options to use my %o = ( delay => 3, mode => 'queues', site => '', min => 1, resolve => 0, config => '/etc/perlbal-check.yaml' ); my $rv = GetOptions(\%o, 'help|h', 'mode=s', 'delay=i', 'site=s', 'min=i', 'resolve', 'config=s'); my $c; eval { $c = LoadFile($o{config}); }; die "Could not load configuration: $@" if $@; parse_config($c, \%o); show_help() if ($o{help}); sub show_help { my $sites = join('|', sort keys %$c); print "$0 [--delay 3 --mode [queues|popular|backend|clients|topclients] --site [$sites] --min 1]\n"; exit 0; } # Hold established perlbal sockets. unless ($c->{$o{site}}) { print "Unknown site passed specified by --site. see help\n"; show_help(); } my %PERLBAL_SOCKS = %{connect_hosts($c->{$o{site}})}; watch_queues() if $o{mode} eq 'queues'; watch_popular($o{min}) if $o{mode} eq 'popular'; watch_backends() if $o{mode} eq 'backend'; watch_clients() if $o{mode} eq 'clients'; watch_top_clients($o{min}) if $o{mode} eq 'topclients'; show_help(); # Uncomment if you want an idea of how the structure looks. #my $r = poll_socks(\%PERLBAL_SOCKS); #print Dumper($r), "\n"; # Flattens out any aggregates in the configuration. # Not recursive :( sub parse_config { my $c = shift; my $o = shift; if (exists $c->{sitedefault}) { my $site = delete $c->{sitedefault}; $o->{site} = $site unless $o->{site}; } for my $site (keys %$c) { next unless (ref($c->{$site}) eq 'ARRAY'); my @new = (); for my $subsite (@{$c->{$site}}) { die "unknown site $subsite" unless exists $c->{$subsite}; die "subsite must be a list of servers" unless (ref($c->{$subsite}) eq 'HASH'); push(@new, map { $_ => $c->{$subsite}->{$_} } keys %{$c->{$subsite}}); } $c->{$site} = {@new}; } # Generate the "all" config. # Stuff can get overwritten, that's fine. my @all = (); for my $site (keys %$c) { push(@all, map { $_ => $c->{$site}->{$_} } keys %{$c->{$site}}); } $c->{all} = {@all}; } sub connect_hosts { my $servers = shift; my %socks = (); for my $name (keys %{$servers}) { my $addr = $servers->{$name}; my $sock; # I don't trust IO::Socket::INET's timeout. Maybe I should? # overriding sigalrm so we don't just bail entirely local $SIG{ALRM} = sub { 1 }; alarm(2); eval { $sock = IO::Socket::INET->new(PeerAddr => $addr, Timeout => 2, Proto => 'tcp'); if ($sock) { $socks{$name} = $sock; } else { print "WARNING: Could not establish connection to $name: $addr\n"; } }; alarm(0); print "WARNING: Failed to establish connection to $name: $addr ERROR: $@\n" if $@; } return \%socks; } # Hideous ip resolution sub with cache. my %RCACHE = (); sub resolve { $RCACHE{$_[0]} = gethostbyaddr(inet_aton($_[0]), AF_INET) unless $RCACHE{$_[0]}; return $RCACHE{$_[0]}; } # Find abusive clients? Bad clients! sub watch_top_clients { my $minimum = shift; while (1) { print "\n" . localtime() . ":\n"; # Sort by IP. my %ips = (); my $r = poll_socks(\%PERLBAL_SOCKS); for my $c (@$r) { next unless $c->{type} =~ m/^Client/; my $o = $c->{o}; next unless $o->{observed_ip}; my $ip = $o->{observed_ip}; $ips{$ip}->{total}++; $ips{$ip}->{drain} += $o->{draining_res} ? 1 : 0; $ips{$ip}->{waiting} += $o->{wait_res} ? 1 : 0; $ips{$ip}->{uris}->{$c->{http}}++ if $c->{http}; } for (sort { $ips{$b}->{total} <=> $ips{$a}->{total} } keys %ips) { my $data = $ips{$_}; next unless $data->{total} > $minimum; my $name = $o{resolve} ? resolve($_) : $_; printf "\ttotal:%3d drain:%3d waiting: %3d %s (%s)\n", $data->{total}, $data->{drain} += 0, $data->{waiting} += 0, $_, $name ? $name : 'NA'; next unless exists $data->{uris}; while (my ($uri, $total) = each %{$data->{uris}}) { printf "\t\t%3d %s\n", $total, $uri; } } exit if $o{delay} == 0; sleep $o{delay}; } } # Some overall stats on connected clients. sub watch_clients { while (1) { print "\n" . localtime() . ":\n"; my $r = poll_socks(\%PERLBAL_SOCKS); my $total = 0; my $reqs = 0; my $bored = 0; my $btime = 0; my $drain = 0; my $dtime = 0; my $wait = 0; my $wtime = 0; for my $c (@$r) { next unless $c->{type} =~ m/^Client/; my $o = $c->{o}; $total++; $reqs += $o->{reqs}; if ($o->{persist_wait}) { $bored++; $btime += $c->{t}; } elsif ($o->{draining_res}) { $drain++; $dtime += $c->{t}; } elsif ($o->{wait_res}) { $wait++; $wtime += $c->{t}; } } printf "\ttotal: %10d avg reqs: %10.2f\n", $total, $reqs / ($total || 1); printf "\tbored: %10d avg time bored: %10.2f\n", $bored, $btime / ($bored || 1); printf "\tdrain: %10d avg time draining: %10.2f\n", $drain, $dtime / ($drain || 1); printf "\twaiting:%10d avg time waiting: %10.2f\n", $wait, $wtime / ($wait || 1); exit if $o{delay} == 0; sleep $o{delay}; } } # Crap sorted list of top urls. sub watch_popular { my $min_counted = shift; while (1) { print "\n" . localtime() . ":\n"; my %u = (); my $r = poll_socks(\%PERLBAL_SOCKS); for my $c (@$r) { next unless $c->{http}; $u{$c->{http}}->{total}++; $u{$c->{http}}->{wait_res} += $c->{o}->{wait_res} ? 1 : 0; $u{$c->{http}}->{xfer_res} += $c->{o}->{xfer_res} ? 1 : 0; } for (sort { $u{$b}->{total} <=> $u{$a}->{total} } keys %u) { my $data = $u{$_}; if ($data->{total} > $min_counted) { printf "\ttotal:%3d wait:%3d xfer:%3d %s\n", $data->{total}, $data->{wait_res}, $data->{xfer_res}, $_; } } if($o{delay} == 0) { exit; } sleep $o{delay}; } } sub watch_backends { my %tr = ( wait_res => 0, has_attention => 0, bored => 0, xfer_res => 0 ); while (1) { print "\n" . localtime() . ":\n"; my %n = (); my $maxlen = 0; my $r = poll_socks(\%PERLBAL_SOCKS); for my $c (@$r) { next unless ($c->{type} eq 'BackendHTTP' && $c->{o}->{has_attention}); my $host = resolve($c->{host}) . ":" . $c->{port}; $maxlen = length($host) if (length($host) > $maxlen); for (keys %tr) { if ($c->{o}->{$_}) { $n{$host}->{$_}++; } elsif (!$n{$host}->{$_}) { $n{$host}->{$_} += 0; } } $n{$host}->{total}++; } for (sort keys %n) { my $b = $n{$_}; printf "%*s:\t%2d/%2d [bored: %02d; wait_res: %02d; xfer: %02d]\n", $maxlen, $_, $b->{total} - $b->{bored}, $b->{total}, $b->{bored}, $b->{wait_res}, $b->{xfer_res}; } if($o{delay} == 0) { exit; } sleep $o{delay}; } } # Parse a line of perlbal socks output into a hash. sub parse_perlbal_sock { my $line = shift; chomp $line; my %s = (); if ($line =~ m/^\s+(\d+)\s+(\d+)s\s+Perlbal::(\w+)\((\w+)\): (\w+) to ([^:]+):(\d+):\s+(.*)/) { $s{fd} = $1; $s{t} = $2; $s{type} = $3; # This should be parsed out into {r} {w} $s{rw} = $4; $s{state} = $5; $s{host} = $6; $s{port} = $7; my $r = $8; for my $chunk (split(/;/, $r)) { $chunk =~ s/^\s+//; $chunk =~ s/\s+$//; if ($chunk =~ m!^http://!i) { $s{http} = $chunk; } elsif ($chunk =~ m/(.*)\s*=\s*(.*)/) { $s{o}->{$1} = $2; } else { $s{o}->{$chunk}++; } } return \%s; } } # Pass in a list of open sockets. Polls, parses, and returns socks output for # each. sub poll_socks { my $socks = shift; my $nodes = 0; my @conns = (); for my $name (keys %$socks) { my $sock = $socks->{$name}; next unless $sock; print $sock "socks\r\n"; X: while (<$sock>) { chomp; last X if /^\./; my $conn = parse_perlbal_sock($_); # Note which perlbal it was observed from. next unless $conn; $conn->{perlbal} = $name; push(@conns, $conn); } $nodes++; } return \@conns; } sub watch_queues { while (1) { print "\n" . localtime() . ":\n"; my $nodes = 0; # Track how many nodes, per service, have queues observed. my %qnodes = (); my %services = (); my $maxlen = 0; for my $name (keys %PERLBAL_SOCKS) { my $sock = $PERLBAL_SOCKS{$name}; next unless $sock; print $sock "queues\r\n"; X: while (<$sock>) { chomp; last X if /^\./; # service queue type count if (m/^([^-]+)-(\w+)\.(\w+)\s(\d+)/) { $services{$1}->{$3}->{$2} = 0 unless exists $services{$1}->{$3}->{$2}; # Keep tabs on the longest service name. $maxlen = length($1) if (length($1) > $maxlen); if ($3 eq 'age') { $services{$1}->{$3}->{$2} = max($services{$1}->{$3}->{$2}, $4); } else { $services{$1}->{$3}->{$2} += $4; } $qnodes{$1}->{$name}++ if $4 > 0; } } $nodes++; } for my $svc (sort keys %services) { my $queues = $services{$svc}; my $queuednodes = $qnodes{$svc} ? scalar keys %{$qnodes{$svc}} : 0; printf "%*s ", $maxlen, $svc; printf "[norm: %5d, age: %2ds] ", $queues->{count}->{normal}, $queues->{age}->{normal}; printf "[hi: %5d, age: %2ds] ", $queues->{count}->{highpri}, $queues->{age}->{highpri}; # Some/old perlbals don't have lowpri printed. if (exists $queues->{count}->{lowpri}) { printf "[lo: %5d, age: %2ds] ", $queues->{count}->{lowpri}, $queues->{age}->{lowpri}; } printf "[queues on: %2d/%2d]\n", $queuednodes, $nodes; } if($o{delay} == 0) { exit; } sleep $o{delay}; } } Perlbal-1.80/CONTRIBUTING0000644000175000017500000000015411503530123015036 0ustar dormandodormandoWant to contribute? Current instructions should be at: http://contributing.appspot.com/perlbal Thanks! Perlbal-1.80/META.yml0000644000175000017500000000245111722625030014464 0ustar dormandodormando--- #YAML:1.0 name: Perlbal version: 1.80 abstract: Reverse-proxy load balancer and webserver author: - Brad Fitzpatrick license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: base: 0 BSD::Resource: 0 Carp: 0 constant: 0 Danga::Socket: 1.44 Errno: 0 Exporter: 0 Fcntl: 0 fields: 0 File::Path: 0 File::Temp: 0 FindBin: 0 Getopt::Long: 0 Hash::Util: 0 HTTP::Date: 0 HTTP::Request: 0 HTTP::Response: 0 IO::File: 0 IO::Handle: 0 IO::Select: 0 IO::Socket::INET: 0 lib: 0 LWP::UserAgent: 0 Scalar::Util: 0 Socket: 0 strict: 0 Sys::Syscall: 0 Test::More: 0.94 Time::HiRes: 0 vars: 0 warnings: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Perlbal-1.80/lib/0000755000175000017500000000000011722625030013757 5ustar dormandodormandoPerlbal-1.80/lib/Perlbal.pm0000644000175000017500000011755011722624733015720 0ustar dormandodormando#!/usr/bin/perl # # Copyright 2004, Danga Interactive, Inc. # Copyright 2005-2007, Six Apart, Ltd. # =head1 NAME Perlbal - Reverse-proxy load balancer and webserver =head1 SEE ALSO L =head1 CONTRIBUTING Got a patch? Or a bug report? Instructions on how to contribute are located here: L Thanks! =head1 COPYRIGHT AND LICENSE Copyright 2004, Danga Interactive, Inc. Copyright 2005-2010, Six Apart, Ltd. You can use and redistribute Perlbal under the same terms as Perl itself. =cut package Perlbal; BEGIN { # keep track of anonymous subs' origins: $^P |= 0x200; } my $has_gladiator = eval "use Devel::Gladiator; 1;"; my $has_cycle = eval "use Devel::Cycle; 1;"; my $has_devel_peek = eval "use Devel::Peek; 1;"; use vars qw($VERSION); $VERSION = '1.80'; use constant DEBUG => $ENV{PERLBAL_DEBUG} || 0; use constant DEBUG_OBJ => $ENV{PERLBAL_DEBUG_OBJ} || 0; use constant TRACK_STATES => $ENV{PERLBAL_TRACK_STATES} || 0; # if on, track states for "state changes" command use strict; use warnings; no warnings qw(deprecated); use IO::Socket; use IO::Handle; use IO::File; $Perlbal::SYSLOG_AVAILABLE = eval { require Sys::Syslog; 1; }; $Perlbal::BSD_RESOURCE_AVAILABLE = eval { require BSD::Resource; 1; }; # incremented every second by a timer: $Perlbal::tick_time = time(); # Set to 1 when we open syslog, and 0 when we close it $Perlbal::syslog_open = 0; use Getopt::Long; use Carp qw(cluck croak); use Errno qw(EBADF); use POSIX qw(SIG_BLOCK SIG_UNBLOCK SIGINT sigprocmask); our(%TrackVar); sub track_var { my ($name, $ref) = @_; $TrackVar{$name} = $ref; } use Perlbal::AIO; use Perlbal::HTTPHeaders; use Perlbal::Service; use Perlbal::Socket; use Perlbal::TCPListener; use Perlbal::UploadListener; use Perlbal::ClientManage; use Perlbal::ClientHTTPBase; use Perlbal::ClientProxy; use Perlbal::ClientHTTP; use Perlbal::BackendHTTP; use Perlbal::ReproxyManager; use Perlbal::Pool; use Perlbal::ManageCommand; use Perlbal::CommandContext; use Perlbal::Util; $SIG{'PIPE'} = "IGNORE"; # handled manually our(%hooks); # hookname => subref our(%service); # servicename -> Perlbal::Service our(%pool); # poolname => Perlbal::Pool our(%plugins); # plugin => 1 (shows loaded plugins) our($last_error); our $service_autonumber = 1; # used to generate names for anonymous services created with Perlbal->create_service() our $vivify_pools = 1; # if on, allow automatic creation of pools our $foreground = 1; # default to foreground our $track_obj = 0; # default to not track creation locations our $reqs = 0; # total number of requests we've done our $starttime = time(); # time we started our $pidfile = ''; # full path, default to not writing pidfile # used by pidfile (only makes sense before run started) # don't rely on this variable, it might change. our $run_started = 0; our ($lastutime, $laststime, $lastreqs) = (0, 0, 0); # for deltas our %PluginCase = (); # lowercase plugin name -> as file is named # setup XS status data structures our %XSModules; # ( 'headers' => 'Perlbal::XS::HTTPHeaders' ) # now include XS files eval "use Perlbal::XS::HTTPHeaders;"; # if we have it, load it # activate modules as necessary if ($ENV{PERLBAL_XS_HEADERS} && $XSModules{headers}) { Perlbal::XS::HTTPHeaders::enable(); } # unactivate field::new if ($ENV{PERLBAL_REMOVE_FIELDS}) { use Perlbal::Fields; Perlbal::Fields->remove(); } # setup a USR1 signal handler that tells us to dump some basic statistics # of how we're doing to the syslog $SIG{'USR1'} = sub { my $dumper = sub { Perlbal::log('info', $_[0]); }; foreach my $svc (values %service) { run_manage_command("show service $svc->{name}", $dumper); } run_manage_command('states', $dumper); run_manage_command('queues', $dumper); }; sub error { $last_error = shift; return 0; } # Object instance counts, for debugging and leak detection our(%ObjCount); # classname -> instances our(%ObjTotal); # classname -> instances our(%ObjTrack); # "$objref" -> creation location sub objctor { if (DEBUG_OBJ) { my $ref = ref $_[0]; $ref .= "-$_[1]" if $_[1]; $ObjCount{$ref}++; $ObjTotal{$ref}++; # now, if we're tracing leaks, note this object's creation location if ($track_obj) { my $i = 1; my @list; while (my $sub = (caller($i++))[3]) { push @list, $sub; } $ObjTrack{"$_[0]"} = [ time, join(', ', @list) ]; } } } sub objdtor { if (DEBUG_OBJ) { my $ref = ref $_[0]; $ref .= "-$_[1]" if $_[1]; $ObjCount{$ref}--; # remove tracking for this object if ($track_obj) { delete $ObjTrack{"$_[0]"}; } } } sub register_global_hook { $hooks{$_[0]} = $_[1]; return 1; } sub unregister_global_hook { delete $hooks{$_[0]}; return 1; } sub run_global_hook { my $hookname = shift; my $ref = $hooks{$hookname}; return $ref->(@_) if defined $ref; # @_ is $mc (a Perlbal::ManageCommand) return undef; } sub service_names { return sort keys %service; } # class method: given a service name, returns a service object sub service { my $class = shift; return $service{$_[0]}; } sub create_service { my $class = shift; my $name = shift; unless (defined($name)) { $name = "____auto_".($service_autonumber++); } croak("service '$name' already exists") if $service{$name}; croak("pool '$name' already exists") if $pool{$name}; # Create the new service and return it return $service{$name} = Perlbal::Service->new($name); } sub pool { my $class = shift; return $pool{$_[0]}; } # given some plugin name, return its correct case sub plugin_case { my $pname = lc shift; return $PluginCase{$pname} || $pname; } # run a block of commands. returns true if they all passed sub run_manage_commands { my ($cmd_block, $out, $ctx) = @_; $ctx ||= Perlbal::CommandContext->new; foreach my $cmd (split(/\n/, $cmd_block)) { return 0 unless Perlbal::run_manage_command($cmd, $out, $ctx); } return 1; } # allows ${ip:eth0} in config. currently the only supported expansion sub _expand_config_var { my $cmd = shift; $cmd =~ /^(\w+):(.+)/ or die "Unknown config variable: $cmd\n"; my ($type, $val) = ($1, $2); if ($type eq "ip") { die "Bogus-looking iface name" unless $val =~ /^\w+$/; my $conf = `/sbin/ifconfig $val`; $conf =~ /inet addr:(\S+)/ or die "Can't find IP of interface '$val'"; return $1; } die "Unknown config variable type: $type\n"; } # returns 1 if command succeeded, 0 otherwise sub run_manage_command { my ($cmd, $out, $ctx) = @_; # $out is output stream closure $cmd =~ s/\#.*//; $cmd =~ s/^\s+//; $cmd =~ s/\s+$//; $cmd =~ s/\s+/ /g; # expand variables my $orig = $cmd; # save original case for some commands $cmd =~ s/\$\{(.+?)\}/_expand_config_var($1)/eg; $cmd =~ s/\$(\w+)/$ENV{$1}/g; $cmd =~ s/^([^=]+)/lc $1/e; # lowercase everything up to an = return 1 unless $cmd =~ /^\S/; $out ||= sub {}; $ctx ||= Perlbal::CommandContext->new; my $err = sub { $out->("ERROR: $_[0]"); return 0; }; my $ok = sub { $out->("OK") if $ctx->verbose; return 1; }; return $err->("invalid command") unless $cmd =~ /^(\w+)/; my $basecmd = $1; my $mc = Perlbal::ManageCommand->new($basecmd, $cmd, $out, $ok, $err, $orig, $ctx); # for testing auto crashing and recovery: if ($basecmd eq "crash") { die "Intentional crash." }; no strict 'refs'; my $handler; if ($Perlbal::{"MANAGE_$basecmd"} && ($handler = *{"MANAGE_$basecmd"}{CODE})) { my $rv = eval { $handler->($mc); }; return $mc->err($@) if $@; return $rv; } # if no handler found, look for plugins # call any hooks if they've been defined my $rval = eval { run_global_hook("manage_command.$basecmd", $mc); }; return $mc->err($@) if $@; if (defined $rval) { # commands may return boolean, or arrayref to mass-print if (ref $rval eq "ARRAY") { $mc->out($_) foreach @$rval; return 1; } return $rval; } return $mc->err("unknown command: $basecmd"); } sub arena_ref_counts { my $all = Devel::Gladiator::walk_arena(); my %ct; my %run_cycle; foreach my $it (@$all) { $ct{ref $it}++; if (ref $it eq "CODE") { my $name = Devel::Peek::CvGV($it); $ct{$name}++ if $name =~ /ANON/; } } $all = undef; return \%ct; } my %last_gladiator; sub MANAGE_gladiator { my $mc = shift->no_opts; unless ($has_gladiator && $has_devel_peek) { $mc->end; return; } my $ct = arena_ref_counts(); my $ret; $ret .= "ARENA COUNTS:\n"; foreach my $k (sort {$ct->{$b} <=> $ct->{$a}} keys %$ct) { my $delta = $ct->{$k} - ($last_gladiator{$k} || 0); $last_gladiator{$k} = $ct->{$k}; next unless $ct->{$k} > 1; $ret .= sprintf(" %4d %-4d $k\n", $ct->{$k}, $delta); } $mc->out($ret); $mc->end; } sub MANAGE_varsize { my $mc = shift->no_opts; my $emit; $emit = sub { my ($v, $depth, $name) = @_; $name ||= ""; my $show; if (ref $v eq "ARRAY") { return unless @$v; $show = "[] " . scalar @$v; } elsif (ref $v eq "HASH") { return unless %$v; $show = "{} " . scalar keys %$v; } else { $show = " = $v"; } my $pre = " " x $depth; $mc->out("$pre$name $show"); if (ref $v eq "HASH") { foreach my $k (sort keys %$v) { $emit->($v->{$k}, $depth+1, "{$k}"); } } }; foreach my $k (sort keys %TrackVar) { my $v = $TrackVar{$k} or next; $emit->($v, 0, $k); } $mc->end; } sub MANAGE_obj { my $mc = shift->no_opts; foreach (sort keys %ObjCount) { $mc->out("$_ = $ObjCount{$_} (tot=$ObjTotal{$_})"); } $mc->end; } sub MANAGE_verbose { my $mc = shift->parse(qr/^verbose (on|off)$/, "usage: VERBOSE {on|off}"); my $onoff = $mc->arg(1); $mc->{ctx}->verbose(lc $onoff eq 'on' ? 1 : 0); return $mc->ok; } sub MANAGE_shutdown { my $mc = shift->parse(qr/^shutdown(\s?graceful)?\s?(\d+)?$/); # immediate shutdown exit(0) unless $mc->arg(1); # set connect ahead to 0 for all services so they don't spawn extra backends foreach my $svc (values %service) { $svc->{connect_ahead} = 0; } # tell all sockets we're doing a graceful stop my $sf = Perlbal::Socket->get_sock_ref; foreach my $k (keys %$sf) { my Perlbal::Socket $v = $sf->{$k}; $v->die_gracefully if $v->can("die_gracefully"); } # register a post loop callback that will end the event loop when we only have # a single socket left, the AIO socket Perlbal::Socket->SetPostLoopCallback(sub { my ($descmap, $otherfds) = @_; # Ghetto: duplicate the code we already had for our postloopcallback Perlbal::Socket::run_callbacks(); # see what we have here; make sure we have no Clients and no unbored Backends foreach my $sock (values %$descmap) { my $ref = ref $sock; return 1 if $ref =~ /^Perlbal::Client/ && $ref ne 'Perlbal::ClientManage'; return 1 if $sock->isa('Perlbal::BackendHTTP') && $sock->{state} ne 'bored'; } return 0; # end the event loop and thus we exit perlbal }); # If requested, register a callback to kill the perlbal process after a specified number of seconds if (my $timeout = $mc->arg(2)) { Perlbal::Socket::register_callback($timeout, sub { exit(0); }); } # so they know something happened return $mc->ok; } sub MANAGE_mime { my $mc = shift->parse(qr/^mime(?:\s+(\w+)(?:\s+(\w+))?(?:\s+(\S+))?)?$/); my ($cmd, $arg1, $arg2) = ($mc->arg(1), $mc->arg(2), $mc->arg(3)); if (!$cmd || $cmd eq 'list') { foreach my $key (sort keys %$Perlbal::ClientHTTPBase::MimeType) { $mc->out("$key $Perlbal::ClientHTTPBase::MimeType->{$key}"); } $mc->end; } elsif ($cmd eq 'set') { if (!$arg1 || !$arg2) { return $mc->err("Usage: set "); } $Perlbal::ClientHTTPBase::MimeType->{$arg1} = $arg2; return $mc->out("$arg1 set to $arg2."); } elsif ($cmd eq 'remove') { if (delete $Perlbal::ClientHTTPBase::MimeType->{$arg1}) { return $mc->out("$arg1 removed."); } else { return $mc->err("$arg1 not a defined extension."); } } else { return $mc->err("Usage: list, remove , set "); } } sub MANAGE_xs { my $mc = shift->parse(qr/^xs(?:\s+(\w+)\s+(\w+))?$/); my ($cmd, $module) = ($mc->arg(1), $mc->arg(2)); if ($cmd) { # command? verify return $mc->err('Known XS modules: ' . join(', ', sort keys %XSModules) . '.') unless $XSModules{$module}; # okay, so now enable or disable this module if ($cmd eq 'enable') { my $res = eval "return $XSModules{$module}::enable();"; return $mc->err("Unable to enable module.") unless $res; return $mc->ok; } elsif ($cmd eq 'disable') { my $res = eval "return $XSModules{$module}::disable();"; return $mc->err("Unable to disable module.") unless $res; return $mc->out("Module disabled."); } else { return $mc->err('Usage: xs [ ]'); } } else { # no commands, so just check status $mc->out('XS module status:', ''); foreach my $module (sort keys %XSModules) { my $class = $XSModules{$module}; my $enabled = eval "return \$${class}::Enabled;"; my $status = defined $enabled ? ($enabled ? "installed, enabled" : "installed, disabled") : "not installed"; $mc->out(" $module: $status"); } $mc->out(' No modules available.') unless %XSModules; $mc->out(''); $mc->out("To enable a module: xs enable "); $mc->out("To disable a module: xs disable "); } $mc->end; } sub MANAGE_fd { my $mc = shift->no_opts; return $mc->err('This command is not available unless BSD::Resource is installed') unless $Perlbal::BSD_RESOURCE_AVAILABLE; # called in list context on purpose, but we want the hard limit my (undef, $max) = BSD::Resource::getrlimit(BSD::Resource::RLIMIT_NOFILE()); my $ct = 0; # first try procfs if one exists, as that's faster than iterating if (opendir(DIR, "/proc/self/fd")) { my @dirs = readdir(DIR); $ct = scalar(@dirs) - 2; # don't count . and .. closedir(DIR); } else { # isatty() is cheap enough to do on everything foreach (0..$max) { my $res = POSIX::isatty($_); $ct++ if $res || ($! != EBADF); } } $mc->out("max $max"); $mc->out("cur $ct"); $mc->end; } sub MANAGE_proc { my $mc = shift->no_opts; $mc->out('time: ' . time()); $mc->out('pid: ' . $$); if ($Perlbal::BSD_RESOURCE_AVAILABLE) { my $ru = BSD::Resource::getrusage(); my ($ut, $st) = ($ru->utime, $ru->stime); my ($udelta, $sdelta) = ($ut - $lastutime, $st - $laststime); $mc->out("utime: $ut (+$udelta)"); $mc->out("stime: $st (+$sdelta)"); ($lastutime, $laststime, $lastreqs) = ($ut, $st, $reqs); } my $rdelta = $reqs - $lastreqs; $mc->out("reqs: $reqs (+$rdelta)"); $lastreqs = $reqs; $mc->end; } sub MANAGE_nodes { my $mc = shift->parse(qr/^nodes?(?:\s+(\d+.\d+.\d+.\d+)(?::(\d+))?)?$/); my ($ip, $port) = ($mc->arg(1), $mc->arg(2) || 80); my $spec_ipport = $ip ? "$ip:$port" : undef; my $ref = \%Perlbal::BackendHTTP::NodeStats; my $dump = sub { my $ipport = shift; foreach my $key (keys %{$ref->{$ipport}}) { if (ref $ref->{$ipport}->{$key} eq 'ARRAY') { my %temp; $temp{$_}++ foreach @{$ref->{$ipport}->{$key}}; foreach my $tkey (keys %temp) { $mc->out("$ipport $key $tkey $temp{$tkey}"); } } else { $mc->out("$ipport $key $ref->{$ipport}->{$key}"); } } }; # dump a node, or all nodes if ($spec_ipport) { $dump->($spec_ipport); } else { foreach my $ipport (keys %$ref) { $dump->($ipport); } } $mc->end; } # singular also works for the nodes command *MANAGE_node = \&MANAGE_nodes; sub MANAGE_prof { my $mc = shift->parse(qr/^prof\w*\s+(on|off|data)$/); my $which = $mc->arg(1); if ($which eq 'on') { if (Danga::Socket->EnableProfiling) { return $mc->ok; } else { return $mc->err('Unable to enable profiling. Please ensure you have the BSD::Resource module installed.'); } } if ($which eq 'off') { Danga::Socket->DisableProfiling; return $mc->ok; } if ($which eq 'data') { my $href = Danga::Socket->ProfilingData; foreach my $key (sort keys %$href) { my ($utime, $stime, $calls) = @{$href->{$key}}; $mc->out(sprintf("%s %0.5f %0.5f %d %0.7f %0.7f", $key, $utime, $stime, $calls, $utime / $calls, $stime / $calls)); } $mc->end; } } sub MANAGE_uptime { my $mc = shift->no_opts; $mc->out("starttime $starttime"); $mc->out("uptime " . (time() - $starttime)); $mc->out("version $Perlbal::VERSION"); $mc->end; } *MANAGE_version = \&MANAGE_uptime; sub MANAGE_track { my $mc = shift->no_opts; my $now = time(); my @list; foreach (keys %ObjTrack) { my $age = $now - $ObjTrack{$_}->[0]; push @list, [ $age, "${age}s $_: $ObjTrack{$_}->[1]" ]; } # now output based on sorted age foreach (sort { $a->[0] <=> $b->[0] } @list) { $mc->out($_->[1]); } $mc->end; } sub MANAGE_socks { my $mc = shift->parse(qr/^socks(?: (\w+))?$/); my $mode = $mc->arg(1) || "all"; my $sf = Perlbal::Socket->get_sock_ref; if ($mode eq "summary") { my %count; my $write_buf = 0; my $open_files = 0; while (my $k = each %$sf) { my Perlbal::Socket $v = $sf->{$k}; $count{ref $v}++; $write_buf += $v->{write_buf_size}; if ($v->isa("Perlbal::ClientHTTPBase")) { my Perlbal::ClientHTTPBase $cv = $v; $open_files++ if $cv->{'reproxy_fh'}; } } foreach (sort keys %count) { $mc->out(sprintf("%5d $_", $count{$_})); } $mc->out(); $mc->out(sprintf("Aggregate write buffer: %.1fk", $write_buf / 1024)); $mc->out(sprintf(" Open files: %d", $open_files)); } elsif ($mode eq "all") { my $now = time; $mc->out(sprintf("%5s %6s", "fd", "age")); foreach (sort { $a <=> $b } keys %$sf) { my $sock = $sf->{$_}; my $age; eval { $age = $now - $sock->{create_time}; }; $age ||= 0; $mc->out(sprintf("%5d %5ds %s", $_, $age, $sock->as_string)); } } $mc->end; } sub MANAGE_backends { my $mc = shift->no_opts; my $sf = Perlbal::Socket->get_sock_ref; my %nodes; # { "Backend" => int count } foreach my $sock (values %$sf) { if ($sock->isa("Perlbal::BackendHTTP")) { my Perlbal::BackendHTTP $cv = $sock; $nodes{"$cv->{ipport}"}++; } } # now print out text foreach my $node (sort keys %nodes) { $mc->out("$node " . $nodes{$node}); } $mc->end; } sub MANAGE_noverify { my $mc = shift->no_opts; # shows the amount of time left for each node marked as noverify my $now = time; foreach my $ipport (keys %Perlbal::BackendHTTP::NoVerify) { my $until = $Perlbal::BackendHTTP::NoVerify{$ipport} - $now; $mc->out("$ipport $until"); } $mc->end; } sub MANAGE_pending { my $mc = shift->no_opts; # shows pending backend connections by service, node, and age my %pend; # { "service" => { "ip:port" => age } } my $now = time; foreach my $svc (values %service) { foreach my $ipport (keys %{$svc->{pending_connects}}) { my Perlbal::BackendHTTP $be = $svc->{pending_connects}->{$ipport}; next unless defined $be; $pend{$svc->{name}}->{$ipport} = $now - $be->{create_time}; } } foreach my $name (sort keys %pend) { foreach my $ipport (sort keys %{$pend{$name}}) { $mc->out("$name $ipport $pend{$name}{$ipport}"); } } $mc->end; } sub MANAGE_states { my $mc = shift->parse(qr/^states(?:\s+(.+))?$/); my $svc; if (defined $mc->arg(1)) { $svc = $service{$mc->arg(1)}; return $mc->err("Service not found.") unless defined $svc; } my $sf = Perlbal::Socket->get_sock_ref; my %states; # { "Class" => { "State" => int count; } } foreach my $sock (values %$sf) { next unless $sock->can('state'); my $state = $sock->state; next unless defined $state; if (defined $svc) { next unless $sock->isa('Perlbal::ClientProxy') || $sock->isa('Perlbal::BackendHTTP') || $sock->isa('Perlbal::ClientHTTP'); next unless $sock->{service} == $svc; } $states{ref $sock}->{$state}++; } # now print out text foreach my $class (sort keys %states) { foreach my $state (sort keys %{$states{$class}}) { $mc->out("$class $state " . $states{$class}->{$state}); } } $mc->end; } sub MANAGE_queues { my $mc = shift->no_opts; my $now = time; foreach my $svc (values %service) { next unless $svc->{role} eq 'reverse_proxy'; my %queues = ( normal => 'waiting_clients', highpri => 'waiting_clients_highpri', lowpri => 'waiting_clients_lowpri', ); while (my ($queue_name, $clients_key) = each %queues) { my $age = 0; my $count = @{$svc->{$clients_key}}; my Perlbal::ClientProxy $oldest = $svc->{$clients_key}->[0]; $age = $now - $oldest->{last_request_time} if defined $oldest; $mc->out("$svc->{name}-$queue_name.age $age"); $mc->out("$svc->{name}-$queue_name.count $count"); } } $mc->end; } sub MANAGE_state { my $mc = shift->parse(qr/^state changes$/); my $hr = Perlbal::Socket->get_statechange_ref; my %final; # { "state" => count } while (my ($obj, $arref) = each %$hr) { $mc->out("$obj: " . join(', ', @$arref)); $final{$arref->[-1]}++; } foreach my $k (sort keys %final) { $mc->out("$k $final{$k}"); } $mc->end; } sub MANAGE_leaks { my $mc = shift->parse(qr/^leaks(?:\s+(.+))?$/); return $mc->err("command disabled without \$ENV{PERLBAL_DEBUG} set") unless $ENV{PERLBAL_DEBUG}; my $what = $mc->arg(1); # iterates over active objects. if you specify an argument, it is treated as code # with $_ being the reference to the object. # shows objects that we think might have been leaked my $ref = Perlbal::Socket::get_created_objects_ref; foreach (@$ref) { next unless $_; # might be undef! if ($what) { my $rv = eval "$what"; return $mc->err("$@") if $@; next unless defined $rv; $mc->out($rv); } else { $mc->out($_->as_string); } } $mc->end; } sub MANAGE_show { my $mc = shift; if ($mc->cmd =~ /^show service (\w+)$/) { my $sname = $1; my Perlbal::Service $svc = $service{$sname}; return $mc->err("Unknown service") unless $svc; $svc->stats_info($mc->out); return $mc->end; } if ($mc->cmd =~ /^show pool(?:\s+(\w+))?$/) { my $pool = $1; if ($pool) { my $pl = $pool{$pool}; return $mc->err("pool '$pool' does not exist") unless $pl; foreach my $node (@{ $pl->nodes }) { my $ipport = "$node->[0]:$node->[1]"; $mc->out($ipport . " " . $pl->node_used($ipport)); } } else { foreach my $name (sort keys %pool) { my Perlbal::Pool $pl = $pool{$name}; $mc->out("$name nodes $pl->{node_count}"); $mc->out("$name services $pl->{use_count}"); } } return $mc->end; } if ($mc->cmd =~ /^show service$/) { foreach my $name (sort keys %service) { my $svc = $service{$name}; my $listen = $svc->{listen} || "not_listening"; $mc->out("$name $listen " . ($svc->{enabled} ? "ENABLED" : "DISABLED")); } return $mc->end; } return $mc->parse_error; } sub MANAGE_server { my $mc = shift->parse(qr/^server (\S+) ?= ?(.+)$/); my ($key, $val) = ($mc->arg(1), $mc->arg(2)); if ($key =~ /^max_reproxy_connections(?:\((.+)\))?/) { return $mc->err("Expected numeric parameter") unless $val =~ /^-?\d+$/; my $hostip = $1; if (defined $hostip) { $Perlbal::ReproxyManager::ReproxyMax{$hostip} = $val+0; } else { $Perlbal::ReproxyManager::ReproxyGlobalMax = $val+0; } return $mc->ok; } if ($key eq "max_connections") { return $mc->err('This command is not available unless BSD::Resource is installed') unless $Perlbal::BSD_RESOURCE_AVAILABLE; return $mc->err("Expected numeric parameter") unless $val =~ /^-?\d+$/; my $rv = BSD::Resource::setrlimit(BSD::Resource::RLIMIT_NOFILE(), $val, $val); unless (defined $rv && $rv) { if ($> == 0) { $mc->err("Unable to set limit."); } else { $mc->err("Need to be root to increase max connections."); } } return $mc->ok; } if ($key eq "nice_level") { return $mc->err("Expected numeric parameter") unless $val =~ /^-?\d+$/; my $rv = POSIX::nice($val); $mc->err("Unable to renice: $!") unless defined $rv; return $mc->ok; } if ($key eq "aio_mode") { return $mc->err("Unknown AIO mode") unless $val =~ /^none|linux|ioaio$/; return $mc->err("Linux::AIO no longer supported") if $val eq "linux"; return $mc->err("IO::AIO not available") if $val eq "ioaio" && ! $Perlbal::OPTMOD_IO_AIO; $Perlbal::AIO_MODE = $val; return $mc->ok; } if ($key eq "aio_threads") { return $mc->err("Expected numeric parameter") unless $val =~ /^-?\d+$/; IO::AIO::min_parallel($val) if $Perlbal::OPTMOD_IO_AIO; return $mc->ok; } if ($key eq "track_obj") { return $mc->err("Expected 1 or 0") unless $val eq '1' || $val eq '0'; $track_obj = $val + 0; %ObjTrack = () if $val; # if we're turning it on, clear it out return $mc->ok; } if ($key eq "pidfile") { return $mc->err("pidfile must be configured at startup, before Perlbal::run is called") if $run_started; return $mc->err("Expected full pathname to pidfile") unless $val; $pidfile = $val; return $mc->ok; } if ($key eq "crash_backtrace") { return $mc->err("Expected 1 or 0") unless $val eq '1' || $val eq '0'; if ($val) { $SIG{__DIE__} = sub { Carp::confess(@_) }; } else { $SIG{__DIE__} = undef; } return $mc->ok; } return $mc->err("unknown server option '$val'"); } sub MANAGE_dumpconfig { my $mc = shift; while (my ($name, $pool) = each %pool) { $mc->out("CREATE POOL $name"); if ($pool->can("dumpconfig")) { foreach my $line ($pool->dumpconfig) { $mc->out(" $line"); } } else { my $class = ref($pool); $mc->out(" # Pool class '$class' is unable to dump config."); } } continue { $mc->out(""); } while (my ($name, $service) = each %service) { $mc->out("CREATE SERVICE $name"); if ($service->can("dumpconfig")) { foreach my $line ($service->dumpconfig) { $mc->out(" $line"); } } else { my $class = ref($service); $mc->out(" # Service class '$class' is unable to dump config."); } my $state = $service->{enabled} ? "ENABLE" : "DISABLE"; $mc->out("$state $name"); } continue { $mc->out(""); } return $mc->ok } sub MANAGE_reproxy_state { my $mc = shift; Perlbal::ReproxyManager::dump_state($mc->out); return 1; } sub MANAGE_create { my $mc = shift->parse(qr/^create (service|pool) (\w+)$/, "usage: CREATE {service|pool} "); my ($what, $name) = $mc->args; if ($what eq "service") { return $mc->err("service '$name' already exists") if $service{$name}; return $mc->err("pool '$name' already exists") if $pool{$name}; Perlbal->create_service($name); $mc->{ctx}{last_created} = $name; return $mc->ok; } if ($what eq "pool") { return $mc->err("pool '$name' already exists") if $pool{$name}; return $mc->err("service '$name' already exists") if $service{$name}; $vivify_pools = 0; $pool{$name} = Perlbal::Pool->new($name); $mc->{ctx}{last_created} = $name; return $mc->ok; } } sub MANAGE_use { my $mc = shift->parse(qr/^use (\w+)$/, "usage: USE "); my ($name) = $mc->args; return $mc->err("Non-existent pool or service '$name'") unless $pool{$name} || $service{$name}; $mc->{ctx}{last_created} = $name; return $mc->ok; } sub MANAGE_pool { my $mc = shift->parse(qr/^pool (\w+) (\w+) (\d+.\d+.\d+.\d+)(?::(\d+))?$/); my ($cmd, $name, $ip, $port) = $mc->args; $port ||= 80; my $good_cmd = qr/^(?:add|remove)$/; # "add" and "remove" can be in either order ($cmd, $name) = ($name, $cmd) if $name =~ /$good_cmd/; return $mc->err("Invalid command: must be 'add' or 'remove'") unless $cmd =~ /$good_cmd/; my $pl = $pool{$name}; return $mc->err("Pool '$name' not found") unless $pl; $pl->$cmd($ip, $port); return $mc->ok; } sub MANAGE_default { my $mc = shift->parse(qr/^default (\w+) ?= ?(.+)$/, "usage: DEFAULT = "); my ($key, $val) = $mc->args; return Perlbal::Service::set_defaults($mc, $key => $val); } sub MANAGE_set { my $mc = shift->parse(qr/^set (?:(\w+)[\. ])?([\w\.]+) ?= ?(.+)$/, "usage: SET [] = "); my ($name, $key, $val) = $mc->args; unless ($name ||= $mc->{ctx}{last_created}) { return $mc->err("omitted service/pool name not implied from context"); } if (my Perlbal::Service $svc = $service{$name}) { return $svc->set($key, $val, $mc); } elsif (my Perlbal::Pool $pl = $pool{$name}) { return $pl->set($key, $val, $mc); } return $mc->err("service/pool '$name' does not exist"); } sub MANAGE_header { my $mc = shift->parse(qr/^header\s+(\w+)\s+(insert|remove)\s+(.+?)(?:\s*:\s*(.+))?$/i, "Usage: HEADER {INSERT|REMOVE}
[: ]"); my ($svc_name, $action, $header, $val) = $mc->args; my $svc = $service{$svc_name}; return $mc->err("service '$svc_name' does not exist") unless $svc; return $svc->header_management($action, $header, $val, $mc); } sub MANAGE_enable { my $mc = shift->parse(qr/^(disable|enable) (\w+)$/, "Usage: {ENABLE|DISABLE} "); my ($verb, $name) = $mc->args; my $svc = $service{$name}; return $mc->err("service '$name' does not exist") unless $svc; return $svc->$verb($mc); } *MANAGE_disable = \&MANAGE_enable; sub MANAGE_unload { my $mc = shift->parse(qr/^unload (\w+)$/); my ($fn) = $mc->args; $fn = $PluginCase{lc $fn}; my $rv = eval "Perlbal::Plugin::$fn->unload; 1;"; $plugins{$fn} = 0; return $mc->ok; } sub MANAGE_load { my $mc = shift->parse(qr/^load \w+$/); my $fn; $fn = $1 if $mc->orig =~ /^load (\w+)$/i; my $last_case; my $last_class; my $good_error; # TODO case protection foreach my $name ($fn, lc $fn, ucfirst lc $fn) { $last_case = $name; my $class = $last_class = "Perlbal::Plugin::$name"; my $file = $class . ".pm"; $file =~ s!::!/!g; my $rv = eval "use $class; $class->can('load');"; if ($rv) { $good_error = undef; last; } # If we don't have a good error yet, start with this one. $good_error = $@ unless defined $good_error; # If the file existed perl will place an entry in %INC (though it will be undef due to compilation error) if ($@ and exists $INC{$file}) { $good_error = $@; last; } } unless (defined $good_error) { my $rv = eval "$last_class->load; 1;"; if ($rv) { $PluginCase{lc $fn} = $last_case; $plugins{$last_case} = $last_class; return $mc->ok; } $good_error = $@; } return $mc->err($good_error); } sub MANAGE_reload { my $mc = shift->parse(qr/^reload (\w+)$/); my ($fn) = $mc->args; my $class = $PluginCase{lc $fn} or return $mc->err("Unknown/unloaded plugin '$fn'"); $class = "Perlbal::Plugin::$class"; eval "$class->can_reload" or return $mc->err("Plugin $class doesn't support reloading"); if ($class->can("pre_reload_unload")) { eval "$class->pre_reload_unload; 1" or return $mc->err("Error running $class->pre_reload_unload: $@"); } eval "$class->unload; 1;" or return $mc->err("Failed to unload $class: $@"); my $file = $class . ".pm"; $file =~ s!::!/!g; delete $INC{$file} or die $mc->err("Didn't find $file in %INC"); no warnings 'redefine'; eval "use $class; $class->load; 1;" or return $mc->err("Failed to reload: $@"); return $mc->ok; } sub MANAGE_plugins { my $mc = shift->no_opts; foreach my $svc (values %service) { next unless @{$svc->{plugin_order}}; $mc->out(join(' ', $svc->{name}, @{$svc->{plugin_order}})); } $mc->end; } sub MANAGE_help { my $mc = shift->no_opts; my @commands = sort map { m/^MANAGE_(\S+)$/ ? $1 : () } keys %Perlbal::; foreach my $command (@commands) { $mc->out("$command"); } $mc->end; } sub MANAGE_aio { my $mc = shift->no_opts; my $stats = Perlbal::AIO::get_aio_stats(); foreach my $c (sort keys %$stats) { my $r = $stats->{$c}; foreach my $k (keys %$r) { $mc->out("$c $k $r->{$k}"); } } $mc->end; } sub load_config { my ($file, $writer) = @_; open (my $fh, $file) or die "Error opening config file ($file): $!\n"; my $ctx = Perlbal::CommandContext->new; $ctx->verbose(0); while (my $line = <$fh>) { return 0 unless run_manage_command($line, $writer, $ctx); } close($fh); return 1; } sub daemonize { my($pid, $sess_id, $i); # note that we're not in the foreground (for logging purposes) $foreground = 0; # required before fork: (as of old Linux::AIO 1.1, still true?) IO::AIO::max_parallel(0) if $Perlbal::OPTMOD_IO_AIO; my $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block sigint for fork: $!"; ## Fork and exit parent if ($pid = fork) { exit 0; } sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock sigint after fork: $!"; ## Detach ourselves from the terminal croak "Cannot detach from controlling terminal" unless $sess_id = POSIX::setsid(); # Handler for INT needs to be restored. $SIG{INT} = 'DEFAULT'; ## Change working directory chdir "/"; ## Clear file creation mask umask 0; ## Close open file descriptors close(STDIN); close(STDOUT); close(STDERR); ## Reopen stderr, stdout, stdin to /dev/null open(STDIN, "+>/dev/null"); open(STDOUT, "+>&STDIN"); open(STDERR, "+>&STDIN"); } # For other apps using Danga::Socket that want to embed Perlbal, this can be called # directly to start it up. You can call this as many times as you like; it'll # only actually do what it does the first time it's called. sub initialize { unless ($run_started) { $run_started = 1; # number of AIO threads. the number of outstanding requests isn't # affected by this IO::AIO::min_parallel(3) if $Perlbal::OPTMOD_IO_AIO; # register IO::AIO pipe which gets written to from threads # doing blocking IO if ($Perlbal::OPTMOD_IO_AIO) { Perlbal::Socket->AddOtherFds(IO::AIO::poll_fileno() => \&IO::AIO::poll_cb); } # The fact that this only runs the first time someone calls initialize() # means that some things which depend on it might be unreliable when # used in an embedded perlbal if there is a race for multiple components # to call initialize(). run_global_hook("pre_event_loop"); } } # This is the function to call if you want Perlbal to be in charge of the event loop. # It won't return until Perlbal is somehow told to exit. sub run { # setup for logging Sys::Syslog::openlog('perlbal', 'pid', 'daemon') if $Perlbal::SYSLOG_AVAILABLE; $Perlbal::syslog_open = 1; Perlbal::log('info', 'beginning run'); my $pidfile_written = 0; $pidfile_written = _write_pidfile( $pidfile ) if $pidfile; Perlbal::initialize(); Danga::Socket->SetLoopTimeout(1000); Danga::Socket->SetPostLoopCallback(sub { $Perlbal::tick_time = time(); Perlbal::Socket::run_callbacks(); return 1; }); # begin the overall loop to try to capture if Perlbal dies at some point # so we can have a log of it eval { # wait for activity Perlbal::Socket->EventLoop(); }; my $clean_exit = 1; # closing messages if ($@) { Perlbal::log('crit', "crash log: $_") foreach split(/\r?\n/, $@); $clean_exit = 0; } # Note: This will only actually remove the pidfile on 'shutdown graceful' # A more reliable approach might be to have a pidfile object which fires # removal on DESTROY. _remove_pidfile( $pidfile ) if $pidfile_written; Perlbal::log('info', 'ending run'); $Perlbal::syslog_open = 0; Sys::Syslog::closelog() if $Perlbal::SYSLOG_AVAILABLE; return $clean_exit; } sub log { # simple logging functionality if ($foreground) { # syslog acts like printf so we have to use printf and append a \n shift; # ignore the first parameter (info, warn, crit, etc) my $message = shift; if (@_) { printf("$message\n", @_); } else { print("$message\n"); } } else { # just pass the parameters to syslog Sys::Syslog::syslog(@_) if $Perlbal::syslog_open; } } sub _write_pidfile { my $file = shift; my $fh; unless (open($fh, ">$file")) { Perlbal::log('info', "couldn't create pidfile '$file': $!" ); return 0; } unless ((print $fh "$$\n") && close($fh)) { Perlbal::log('info', "couldn't write into pidfile '$file': $!" ); _remove_pidfile($file); return 0; } return 1; } sub _remove_pidfile { my $file = shift; unlink $file; return 1; } # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: 1; Perlbal-1.80/lib/Perlbal/0000755000175000017500000000000011722625030015340 5ustar dormandodormandoPerlbal-1.80/lib/Perlbal/ClientHTTPBase.pm0000644000175000017500000010166211630514744020424 0ustar dormandodormando###################################################################### # Common HTTP functionality for ClientProxy and ClientHTTP # possible states: # reading_headers (initial state, then follows one of two paths) # wait_backend, backend_req_sent, wait_res, xfer_res, draining_res # wait_stat, wait_open, xfer_disk # both paths can then go into persist_wait, which means they're waiting # for another request from the user # # Copyright 2004, Danga Interactive, Inc. # Copyright 2005-2007, Six Apart, Ltd. package Perlbal::ClientHTTPBase; use strict; use warnings; no warnings qw(deprecated); use Sys::Syscall; use base "Perlbal::Socket"; use HTTP::Date (); use fields ('service', # Perlbal::Service object 'replacement_uri', # URI to send instead of the one requested; this is used # to instruct _serve_request to send an index file instead # of trying to serve a directory and failing 'scratch', # extra storage; plugins can use it if they want # reproxy support 'reproxy_file', # filename the backend told us to start opening 'reproxy_file_size', # size of file, once we stat() it 'reproxy_fh', # if needed, IO::Handle of fd 'reproxy_file_offset', # how much we've sent from the file. 'post_sendfile_cb', # subref to run after we're done sendfile'ing the current file 'requests', # number of requests this object has performed for the user # service selector parent 'selector_svc', # the original service from which we came 'is_ssl', # Is this socket SSL attached (restricted operations) ); use Fcntl ':mode'; use Errno qw(EPIPE ECONNRESET); use POSIX (); # hard-code defaults can be changed with MIME management command our $MimeType = {qw( css text/css doc application/msword gif image/gif htm text/html html text/html jpg image/jpeg js application/x-javascript mp3 audio/mpeg mpg video/mpeg pdf application/pdf png image/png tif image/tiff tiff image/tiff torrent application/x-bittorrent txt text/plain zip application/zip )}; # ClientHTTPBase sub new { my Perlbal::ClientHTTPBase $self = shift; my ($service, $sock, $selector_svc) = @_; $self = fields::new($self) unless ref $self; $self->SUPER::new($sock); # init base fields $self->{service} = $service; $self->{replacement_uri} = undef; $self->{headers_string} = ''; $self->{requests} = 0; $self->{scratch} = {}; $self->{selector_svc} = $selector_svc; $self->{is_ssl} = 0; $self->state('reading_headers'); $self->watch_read(1); return $self; } sub new_from_base { my $class = shift; my Perlbal::ClientHTTPBase $cb = shift; # base object Perlbal::Util::rebless($cb, $class); $cb->handle_request; return $cb; } sub close { my Perlbal::ClientHTTPBase $self = shift; # don't close twice return if $self->{closed}; # could contain a closure with circular reference $self->{post_sendfile_cb} = undef; # close the file we were reproxying, if any CORE::close($self->{reproxy_fh}) if $self->{reproxy_fh}; # now pass up the line $self->SUPER::close(@_); } # given the response headers we just got, and considering our request # headers, determine if we should be sending keep-alive header # information back to the client sub setup_keepalive { my Perlbal::ClientHTTPBase $self = $_[0]; print "ClientHTTPBase::setup_keepalive($self)\n" if Perlbal::DEBUG >= 2; # now get the headers we're using my Perlbal::HTTPHeaders $reshd = $_[1]; my Perlbal::HTTPHeaders $rqhd = $self->{req_headers}; my $override_value = $_[2]; # for now, we enforce outgoing HTTP 1.0 $reshd->set_version("1.0"); # if we came in via a selector service, that's whose settings # we respect for persist_client my $svc = $self->{selector_svc} || $self->{service}; my $persist_client = $svc->{persist_client} || 0; $persist_client = $override_value if defined $override_value; print " service's persist_client = $persist_client\n" if Perlbal::DEBUG >= 3; # do keep alive if they sent content-length or it's a head request my $do_keepalive = $persist_client && $rqhd->req_keep_alive($reshd); if ($do_keepalive) { print " doing keep-alive to client\n" if Perlbal::DEBUG >= 3; my $timeout = $self->{service}->{persist_client_idle_timeout}; $reshd->header('Connection', 'keep-alive'); $reshd->header('Keep-Alive', $timeout ? "timeout=$timeout, max=100" : undef); } else { print " doing connection: close\n" if Perlbal::DEBUG >= 3; # FIXME: we don't necessarily want to set connection to close, # but really set a space-separated list of tokens which are # specific to the connection. "close" and "keep-alive" are # just special. $reshd->header('Connection', 'close'); $reshd->header('Keep-Alive', undef); } } # overridden here from Perlbal::Socket to use the service value sub max_idle_time { my Perlbal::ClientHTTPBase $self = shift; if ($self->state eq 'persist_wait') { return $self->{service}->{persist_client_idle_timeout}; } else { return $self->{service}->{idle_timeout}; } } # Called when this client is entering a persist_wait state, but before we are returned to base. sub persist_wait { } # called when we've finished writing everything to a client and we need # to reset our state for another request. returns 1 to mean that we should # support persistence, 0 means we're discarding this connection. sub http_response_sent { my Perlbal::ClientHTTPBase $self = $_[0]; # close if we're supposed to if ( ! defined $self->{res_headers} || ! $self->{res_headers}->res_keep_alive($self->{req_headers}) || $self->{do_die} ) { # do a final read so we don't have unread_data_waiting and RST # the connection. IE and others send an extra \r\n after POSTs my $dummy = $self->read(5); # close if we have no response headers or they say to close $self->close("no_keep_alive"); return 0; } # if they just did a POST, set the flag that says we might expect # an unadvertised \r\n coming from some browsers. Old Netscape # 4.x did this on all POSTs, and Firefox/Safari do it on # XmlHttpRequest POSTs. if ($self->{req_headers}->request_method eq "POST") { $self->{ditch_leading_rn} = 1; } # now since we're doing persistence, uncork so the last packet goes. # we will recork when we're processing a new request. $self->tcp_cork(0); # reset state $self->{replacement_uri} = undef; $self->{headers_string} = ''; $self->{req_headers} = undef; $self->{res_headers} = undef; $self->{reproxy_fh} = undef; $self->{reproxy_file} = undef; $self->{reproxy_file_size} = 0; $self->{reproxy_file_offset} = 0; $self->{read_buf} = []; $self->{read_ahead} = 0; $self->{read_size} = 0; $self->{scratch} = {}; $self->{post_sendfile_cb} = undef; $self->state('persist_wait'); $self->persist_wait; if (my $selector_svc = $self->{selector_svc}) { if (! $selector_svc->run_hook('return_to_base', $self)){ $selector_svc->return_to_base($self); } } # NOTE: because we only speak 1.0 to clients they can't have # pipeline in a read that we haven't read yet. $self->watch_read(1); $self->watch_write(0); return 1; } sub reproxy_fh { my Perlbal::ClientHTTPBase $self = shift; # setter if (@_) { my ($fh, $size) = @_; $self->state('xfer_disk'); $self->{reproxy_fh} = $fh; $self->{reproxy_file_offset} = 0; $self->{reproxy_file_size} = $size; my $is_ssl_webserver = ( $self->{service}->{listener}->{sslopts} && ( $self->{service}->{role} eq 'web_server') ); unless ($is_ssl_webserver) { # call hook that we're reproxying a file return $fh if $self->{service}->run_hook("start_send_file", $self); # turn on writes (the hook might not have wanted us to) $self->watch_write(1); return $fh; } else { # use aio_read for ssl webserver instead of sendfile print "webserver in ssl mode, sendfile disabled!\n" if $Perlbal::DEBUG >= 3; # turn off writes $self->watch_write(0); #create filehandle for reading my $data = ''; Perlbal::AIO::aio_read($self->reproxy_fh, 0, 2048, $data, sub { # got data? undef is error return $self->_simple_response(500) unless $_[0] > 0; # seek into the file now so sendfile starts further in my $ld = length $data; sysseek($self->{reproxy_fh}, $ld, &POSIX::SEEK_SET); $self->{reproxy_file_offset} = $ld; # reenable writes after we get data $self->tcp_cork(1); # by setting reproxy_file_offset above, # it won't cork, so we cork it $self->write($data); $self->watch_write(1); }); return 1; } } return $self->{reproxy_fh}; } sub event_read { my Perlbal::ClientHTTPBase $self = shift; $self->{alive_time} = $Perlbal::tick_time; # see if we have headers? die "Shouldn't get here! This is an abstract base class, pretty much, except in the case of the 'selector' role." if $self->{req_headers}; my $hd = $self->read_request_headers; $self->handle_request; } sub handle_request { my Perlbal::ClientHTTPBase $self = shift; my Perlbal::HTTPHeaders $hd = $self->{req_headers}; return unless $hd; $self->check_req_headers; return if $self->{service}->run_hook('start_http_request', $self); # we must stop watching for events now, otherwise if there's # PUT/POST overflow, it'll be sent to ClientHTTPBase, which can't # handle it yet. must wait for the selector (which has as much # time as it wants) to route as to our subclass, which can then # re-enable reads. $self->watch_read(0); my $select = sub { # now that we have headers, it's time to tell the selector # plugin that it's time for it to select which real service to # use my $selector = $self->{'service'}->selector(); return $self->_simple_response(500, "No service selector configured.") unless ref $selector eq "CODE"; $selector->($self); }; my $svc = $self->{'service'}; if ($svc->{latency}) { Danga::Socket->AddTimer($svc->{latency} / 1000, $select); } else { $select->(); } } sub reproxy_file_done { my Perlbal::ClientHTTPBase $self = shift; return if $self->{service}->run_hook('reproxy_fh_finished', $self); # close the sendfile fd CORE::close($self->{reproxy_fh}); $self->{reproxy_fh} = undef; if (my $cb = $self->{post_sendfile_cb}) { $cb->(); } else { $self->http_response_sent; } } # client is ready for more of its file. so sendfile some more to it. # (called by event_write when we're actually in this mode) sub event_write_reproxy_fh { my Perlbal::ClientHTTPBase $self = shift; my $remain = $self->{reproxy_file_size} - $self->{reproxy_file_offset}; $self->tcp_cork(1) if $self->{reproxy_file_offset} == 0; $self->watch_write(0); if ($self->{is_ssl}) { # SSL (sendfile does not do SSL) return if $self->{closed}; if ($remain <= 0) { #done print "REPROXY SSL done\n" if Perlbal::DEBUG >= 2; $self->reproxy_file_done; return; } # queue up next read Perlbal::AIO::set_file_for_channel($self->{reproxy_file}); my $len = $remain > 4096 ? 4096 : $remain; # buffer size my $buffer = ''; Perlbal::AIO::aio_read( $self->{reproxy_fh}, $self->{reproxy_file_offset}, $len, $buffer, sub { return if $self->{closed}; # we have buffer to send my $rv = $_[0]; # arg is result of sysread if (!defined($rv) || $rv <= 0) { # read error # sysseek is called after sysread so $! not valid $self->close('sysread_error'); print STDERR "Error w/ reproxy sysread\n"; return; } $self->{reproxy_file_offset} += $rv; $self->tcp_cork(1); # by setting reproxy_file_offset above, # it won't cork, so we cork it $self->write($buffer); # start socket send $self->watch_write(1); } ); return; } # cap at 128k sendfiles my $to_send = $remain > 128 * 1024 ? 128 * 1024 : $remain; my $postread = sub { return if $self->{closed}; my $sent = Perlbal::Socket::sendfile($self->{fd}, fileno($self->{reproxy_fh}), $to_send); #warn "to_send = $to_send, sent = $sent\n"; print "REPROXY Sent: $sent\n" if Perlbal::DEBUG >= 2; if ($sent < 0) { return $self->close("epipe") if $! == EPIPE; return $self->close("connreset") if $! == ECONNRESET; print STDERR "Error w/ sendfile: $!\n"; $self->close('sendfile_error'); return; } $self->{reproxy_file_offset} += $sent; if ($sent >= $remain) { $self->reproxy_file_done; } else { $self->watch_write(1); } }; # TODO: way to bypass readahead and go straight to sendfile for common/hot/recent files. # something like: # if ($hot) { $postread->(); return ; } if ($to_send < 0) { Perlbal::log('warning', "tried to readahead negative bytes. filesize=$self->{reproxy_file_size}, offset=$self->{reproxy_file_offset}"); # this code, doing sendfile, will fail gracefully with return # code, not 'die', and we'll close with sendfile_error: $postread->(); return; } Perlbal::AIO::set_file_for_channel($self->{reproxy_file}); Perlbal::AIO::aio_readahead($self->{reproxy_fh}, $self->{reproxy_file_offset}, $to_send, $postread); } sub event_write { my Perlbal::ClientHTTPBase $self = shift; # Any HTTP client is considered alive if it's writable. # if it's not writable for 30 seconds, we kill it. # subclasses can decide what's appropriate for timeout. $self->{alive_time} = $Perlbal::tick_time; # if we're sending a filehandle, go do some more sendfile: if ($self->{reproxy_fh}) { $self->event_write_reproxy_fh; return; } # otherwise just kick-start our write buffer. if ($self->write(undef)) { # we've written all data in the queue, so stop waiting for # write notifications: print "All writing done to $self\n" if Perlbal::DEBUG >= 2; $self->watch_write(0); } } # this gets called when a "web" service is serving a file locally. sub _serve_request { my Perlbal::ClientHTTPBase $self = shift; my Perlbal::HTTPHeaders $hd = shift; my $rm = $hd->request_method; unless ($rm eq "HEAD" || $rm eq "GET") { return $self->_simple_response(403, "Unimplemented method"); } my $uri = Perlbal::Util::durl($self->{replacement_uri} || $hd->request_uri); my Perlbal::Service $svc = $self->{service}; # start_serve_request hook return 1 if $self->{service}->run_hook('start_serve_request', $self, \$uri); # don't allow directory traversal if ($uri =~ m!/\.\./! || $uri !~ m!^/!) { return $self->_simple_response(403, "Bogus URL"); } # double question mark means to serve multiple files, comma separated after the # questions. the uri part before the question mark is the relative base directory # TODO: only do this if $uri has ?? and the service also allows it. otherwise # we don't want to mess with anybody's meaning of '??' on the backend service return $self->_serve_request_multiple($hd, $uri) if $uri =~ /\?\?/; # chop off the query string $uri =~ s/\?.*//; return $self->_simple_response(500, "Docroot unconfigured") unless $svc->{docroot}; my $file = $svc->{docroot} . $uri; # update state, since we're now waiting on stat $self->state('wait_stat'); Perlbal::AIO::aio_stat($file, sub { # client's gone anyway return if $self->{closed}; unless (-e _) { return if $self->{service}->run_hook('static_get_poststat_file_missing', $self); return $self->_simple_response(404); } my $mtime = (stat(_))[9]; my $lastmod = HTTP::Date::time2str($mtime); my $ims = $hd->header("If-Modified-Since") || ""; # IE sends a request header like "If-Modified-Since: ; length=" # so we have to remove the length bit before comparing it with our date. # then we save the length to compare later. my $ims_len; if ($ims && $ims =~ s/; length=(\d+)//) { $ims_len = $1; } my $not_mod = $ims eq $lastmod && -f _; my $res; my $not_satisfiable = 0; my $size = -s _ if -f _; # extra protection for IE, since it's offering the info anyway. (see above) $not_mod = 0 if $ims_len && $ims_len != $size; my ($status, $range_start, $range_end) = $hd->range($size); if ($not_mod) { $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304); } elsif ($status == 416) { $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(416); $res->header("Content-Range", $size ? "bytes */$size" : "*"); $res->header("Content-Length", 0); $not_satisfiable = 1; } elsif ($status == 206) { # partial content $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(206); } else { return if $self->{service}->run_hook('static_get_poststat_pre_send', $self, $mtime); $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200); } # now set whether this is keep-alive or not $res->header("Date", HTTP::Date::time2str()); $res->header("Server", "Perlbal") if $self->{service}{server_tokens}; $res->header("Last-Modified", $lastmod); if (-f _) { # advertise that we support byte range requests $res->header("Accept-Ranges", "bytes"); unless ($not_mod || $not_satisfiable) { my ($ext) = ($file =~ /\.(\w+)$/); $res->header("Content-Type", (defined $ext && exists $MimeType->{$ext}) ? $MimeType->{$ext} : "text/plain"); unless ($status == 206) { $res->header("Content-Length", $size); } else { $res->header("Content-Range", "bytes $range_start-$range_end/$size"); $res->header("Content-Length", $range_end - $range_start + 1); } } # has to happen after content-length is set to work: $self->setup_keepalive($res); return if $self->{service}->run_hook('modify_response_headers', $self); if ($rm eq "HEAD" || $not_mod || $not_satisfiable) { # we can return already, since we know the size $self->tcp_cork(1); $self->state('xfer_resp'); $self->write($res->to_string_ref); $self->write(sub { $self->http_response_sent; }); return; } # state update $self->state('wait_open'); Perlbal::AIO::aio_open($file, 0, 0, sub { my $rp_fh = shift; # if client's gone, just close filehandle and abort if ($self->{closed}) { CORE::close($rp_fh) if $rp_fh; return; } # handle errors if (! $rp_fh) { # couldn't open the file we had already successfully stat'ed. # FIXME: do 500 vs. 404 vs whatever based on $! return $self->close('aio_open_failure'); } $self->state('xfer_disk'); $self->tcp_cork(1); # cork writes to self $self->write($res->to_string_ref); # seek if partial content if ($status == 206) { sysseek($rp_fh, $range_start, &POSIX::SEEK_SET); $size = $range_end - $range_start + 1; } $self->{reproxy_file} = $file; $self->reproxy_fh($rp_fh, $size); }); } elsif (-d _) { $self->try_index_files($hd, $res, $uri); } }); } sub _serve_request_multiple { my Perlbal::ClientHTTPBase $self = shift; my ($hd, $uri) = @_; my @multiple_files; my %statinfo; # file -> [ stat fields ] # double question mark means to serve multiple files, comma # separated after the questions. the uri part before the question # mark is the relative base directory my ($base, $list) = ($uri =~ /(.+)\?\?(.+)/); unless ($base =~ m!/$!) { return $self->_simple_response(500, "Base directory (before ??) must end in slash.") } # and remove any trailing ?.+ on the list, so you can do things like cache busting # with a ?v= at the end of a list of files. $list =~ s/\?.+//; my Perlbal::Service $svc = $self->{service}; return $self->_simple_response(500, "Docroot unconfigured") unless $svc->{docroot}; @multiple_files = split(/,/, $list); return $self->_simple_response(403, "Multiple file serving isn't enabled") unless $svc->{enable_concatenate_get}; return $self->_simple_response(403, "Too many files requested") if @multiple_files > 100; return $self->_simple_response(403, "Bogus filenames") if grep { m!(?:\A|/)\.\./! } @multiple_files; my $remain = @multiple_files + 1; # 1 for the base directory my $dirbase = $svc->{docroot} . $base; foreach my $file ('', @multiple_files) { Perlbal::AIO::aio_stat("$dirbase$file", sub { $remain--; $statinfo{$file} = $! ? [] : [ stat(_) ]; return if $remain || $self->{closed}; $self->_serve_request_multiple_poststat($hd, $dirbase, \@multiple_files, \%statinfo); }); } } sub _serve_request_multiple_poststat { my Perlbal::ClientHTTPBase $self = shift; my ($hd, $basedir, $filelist, $stats) = @_; # base directory must be a directory unless (S_ISDIR($stats->{''}[2] || 0)) { return $self->_simple_response(404, "Base directory not a directory"); } # files must all exist my $sum_length = 0; my $most_recent_mod = 0; my $mime; # undef until set, or defaults to text/plain later foreach my $f (@$filelist) { my $stat = $stats->{$f}; unless (S_ISREG($stat->[2] || 0)) { return if $self->{service}->run_hook('concat_get_poststat_file_missing', $self); return $self->_simple_response(404, "One or more file does not exist"); } if (!$mime && $f =~ /\.(\w+)$/ && $MimeType->{$1}) { $mime = $MimeType->{$1}; } $sum_length += $stat->[7]; $most_recent_mod = $stat->[9] if $stat->[9] >$most_recent_mod; } $mime ||= 'text/plain'; my $lastmod = HTTP::Date::time2str($most_recent_mod); my $ims = $hd->header("If-Modified-Since") || ""; # IE sends a request header like "If-Modified-Since: ; length=" # so we have to remove the length bit before comparing it with our date. # then we save the length to compare later. my $ims_len; if ($ims && $ims =~ s/; length=(\d+)//) { $ims_len = $1; } # What is -f _ doing here? don't we detect the existence of all files above in the loop? my $not_mod = $ims eq $lastmod && -f _; my $res; if ($not_mod) { $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304); } else { return if $self->{service}->run_hook('concat_get_poststat_pre_send', $self, $most_recent_mod); $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200); $res->header("Content-Length", $sum_length); } $res->header("Date", HTTP::Date::time2str()); $res->header("Server", "Perlbal") if $self->{service}{server_tokens}; $res->header("Last-Modified", $lastmod); $res->header("Content-Type", $mime); # has to happen after content-length is set to work: $self->setup_keepalive($res); return if $self->{service}->run_hook('modify_response_headers', $self); if ($hd->request_method eq "HEAD" || $not_mod) { # we can return already, since we know the size $self->tcp_cork(1); $self->state('xfer_resp'); $self->write($res->to_string_ref); $self->write(sub { $self->http_response_sent; }); return; } $self->tcp_cork(1); # cork writes to self $self->write($res->to_string_ref); $self->state('wait_open'); # gotta send all files, one by one... my @remain = @$filelist; $self->{post_sendfile_cb} = sub { unless (@remain) { $self->write(sub { $self->http_response_sent; }); return; } my $file = shift @remain; my $fullfile = "$basedir$file"; my $size = $stats->{$file}[7]; Perlbal::AIO::aio_open($fullfile, 0, 0, sub { my $rp_fh = shift; # if client's gone, just close filehandle and abort if ($self->{closed}) { CORE::close($rp_fh) if $rp_fh; return; } # handle errors if (! $rp_fh) { # couldn't open the file we had already successfully stat'ed. # FIXME: do 500 vs. 404 vs whatever based on $! return $self->close('aio_open_failure'); } $self->{reproxy_file} = $file; $self->reproxy_fh($rp_fh, $size); }); }; $self->{post_sendfile_cb}->(); } sub check_req_headers { my Perlbal::ClientHTTPBase $self = shift; my Perlbal::HTTPHeaders $hds = $self->{req_headers}; if ($self->{service}->trusted_ip($self->peer_ip_string)) { my @ips = split /,\s*/, ($hds->header("X-Forwarded-For") || ''); # This list may be empty, and that's OK, in that case we should unset the # observed_ip_string, so no matter what we'll use the 0th element, whether # it happens to be an ip string, or undef. $self->observed_ip_string($ips[0]); } return; } sub try_index_files { my Perlbal::ClientHTTPBase $self = shift; my ($hd, $res, $uri, $filepos) = @_; # make sure this starts at 0 initially, and fail if it's past the end $filepos ||= 0; if ($filepos >= scalar(@{$self->{service}->{index_files} || []})) { unless ($self->{service}->{dirindexing}) { # just inform them that listing is disabled $self->_simple_response(200, "Directory listing disabled"); return; } # ensure uri has one and only one trailing slash for better URLs $uri =~ s!/*$!/!; # open the directory and create an index my $body = ""; my $file = $self->{service}->{docroot} . $uri; $res->header("Content-Type", "text/html"); opendir(D, $file); foreach my $de (sort readdir(D)) { if (-d "$file/$de") { $body .= "$de
\n"; } else { $body .= "$de
\n"; } } closedir(D); $body .= ""; $res->header("Content-Length", length($body)); $self->setup_keepalive($res); $self->state('xfer_resp'); $self->tcp_cork(1); # cork writes to self $self->write($res->to_string_ref); $self->write(\$body); $self->write(sub { $self->http_response_sent; }); return; } # construct the file path we need to check my $file = $self->{service}->{index_files}->[$filepos]; my $fullpath = $self->{service}->{docroot} . $uri . '/' . $file; # now see if it exists Perlbal::AIO::aio_stat($fullpath, sub { return if $self->{closed}; return $self->try_index_files($hd, $res, $uri, $filepos + 1) unless -f _; # at this point the file exists, so we just want to serve it $self->{replacement_uri} = $uri . '/' . $file; return $self->_serve_request($hd); }); } sub _simple_response { my Perlbal::ClientHTTPBase $self = shift; my ($code, $msg) = @_; # or bodyref my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response($code); my $body; if ($code != 204 && $code != 304) { $res->header("Content-Type", "text/html"); my $en = $res->http_code_english; $body = "

$code" . ($en ? " - $en" : "") . "

\n"; $body .= $msg if $msg; $res->header('Content-Length', length($body)); } $res->header('Server', 'Perlbal') if $self->{service}{server_tokens}; $self->setup_keepalive($res); $self->state('xfer_resp'); $self->tcp_cork(1); # cork writes to self $self->write($res->to_string_ref); if (defined $body) { unless ($self->{req_headers} && $self->{req_headers}->request_method eq 'HEAD') { # don't write body for head requests $self->write(\$body); } } $self->write(sub { $self->http_response_sent; }); return 1; } sub send_response { my Perlbal::ClientHTTPBase $self = shift; $self->watch_read(0); $self->watch_write(1); return $self->_simple_response(@_); } sub send_full_response { my Perlbal::ClientHTTPBase $self = shift; my $code = shift; my $headers = shift || []; my $bref = ref($_[0]) eq 'SCALAR' ? shift : \shift; my $options = shift || {}; my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response($code); while (@$headers) { my ($name, $value) = splice @$headers, 0, 2; $res->header($name, $value); } if ($code == 204 || $code == 304) { $res->header('Content-Length', undef); $bref = \undef; } elsif (defined $$bref) { $res->header('Content-Length', length($$bref)); } $res->header('Server', 'Perlbal') if $self->{service}{server_tokens}; # $res->header('Date', # We should do this $self->setup_keepalive($res, $options->{persist_client}); $self->state('xfer_resp'); $self->tcp_cork(1); # cork writes to self $self->write($res->to_string_ref); if (defined $$bref && $self->{req_headers} && $self->{req_headers}->request_method ne 'HEAD') { # don't write body for head requests $self->write($bref); } $self->write(sub { $self->http_response_sent; }); return 1; } # method that sends a 500 to the user but logs it and any extra information # we have about the error in question sub system_error { my Perlbal::ClientHTTPBase $self = shift; my ($msg, $info) = @_; # log to syslog Perlbal::log('warning', "system error: $msg ($info)"); # and return a 500 return $self->send_response(500, $msg); } sub event_err { my $self = shift; $self->close('error'); } sub event_hup { my $self = shift; $self->close('hup'); } sub _sock_port { my $name = $_[0]; my $port = eval { (Socket::sockaddr_in($name))[0] }; return $port unless $@; # fallback to IPv6: return (Socket6::unpack_sockaddr_in($name))[0]; } sub as_string { my Perlbal::ClientHTTPBase $self = shift; my $ret = $self->SUPER::as_string; my $name = $self->{sock} ? getsockname($self->{sock}) : undef; my $lport = $name ? _sock_port($name) : undef; my $observed = $self->observed_ip_string; $ret .= ": localport=$lport" if $lport; $ret .= "; observed_ip=$observed" if defined $observed; $ret .= "; reqs=$self->{requests}"; $ret .= "; $self->{state}"; my $hd = $self->{req_headers}; if (defined $hd) { my $host = $hd->header('Host') || 'unknown'; $ret .= "; http://$host" . $hd->request_uri; } return $ret; } 1; # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Perlbal-1.80/lib/Perlbal/ChunkedUploadState.pm0000644000175000017500000000324711503530123021426 0ustar dormandodormandopackage Perlbal::ChunkedUploadState; use strict; sub new { my ($pkg, %args) = @_; my $self = bless { 'buf' => '', 'bytes_remain' => 0, # remaining in chunk (ignoring final 2 byte CRLF) }, $pkg; foreach my $k (qw(on_new_chunk on_disconnect on_zero_chunk)) { $self->{$k} = (delete $args{$k}) || sub {}; } die "bogus args" if %args; return $self; } sub on_readable { my ($self, $ds) = @_; my $rbuf = $ds->read(131072); unless (defined $rbuf) { $self->{on_disconnect}->(); return; } $self->{buf} .= $$rbuf; while ($self->drive_machine) {} } # returns 1 if progress was made parsing buffer sub drive_machine { my $self = shift; my $buflen = length($self->{buf}); return 0 unless $buflen; if (my $br = $self->{bytes_remain}) { my $extract = $buflen > $br ? $br : $buflen; my $ch = substr($self->{buf}, 0, $extract, ''); $self->{bytes_remain} -= $extract; die "assert" if $self->{bytes_remain} < 0; $self->{on_new_chunk}->(\$ch); return 1; } return 0 unless $self->{buf} =~ s/^(?:\r\n)?([0-9a-fA-F]+)(?:;.*)?\r\n//; $self->{bytes_remain} = hex($1); if ($self->{bytes_remain} == 0) { # FIXME: new state machine state for trailer parsing/discarding. # (before we do on_zero_chunk). for now, though, just assume # no trailers and throw away the extra post-trailer \r\n that # is probably in this packet. hacky. $self->{buf} =~ s/^\r\n//; $self->{hit_zero} = 1; $self->{on_zero_chunk}->(); return 0; } return 1; } sub hit_zero_chunk { $_[0]{hit_zero} } 1; Perlbal-1.80/lib/Perlbal/ManageCommand.pm0000644000175000017500000000450311503530123020362 0ustar dormandodormando# class representing a one-liner management command. all the responses # to a command should be done through this instance (out, err, ok, etc) # # Copyright 2005-2007, Six Apart, Ltd. # package Perlbal::ManageCommand; use strict; use warnings; no warnings qw(deprecated); use fields ( 'base', # the base command name (like "proc") 'cmd', 'ok', 'err', 'out', 'orig', 'argn', 'ctx', ); sub new { my ($class, $base, $cmd, $out, $ok, $err, $orig, $ctx) = @_; my $self = fields::new($class); $self->{base} = $base; $self->{cmd} = $cmd; $self->{ok} = $ok; $self->{err} = $err; $self->{out} = $out; $self->{orig} = $orig; $self->{ctx} = $ctx; $self->{argn} = []; return $self; } # returns an managecommand object for functions that need one, but # this does nothing but explode if there any problems. sub loud_crasher { use Carp qw(confess); __PACKAGE__->new(undef, undef, sub {}, sub {}, sub { confess "MC:err: @_" }, "", Perlbal::CommandContext->new); } sub out { my $mc = shift; return @_ ? $mc->{out}->(@_) : $mc->{out}; } sub ok { my $mc = shift; return $mc->{ok}->(@_); } sub err { my ($mc, $err) = @_; $err =~ s/\n$//; $mc->{err}->($err); } sub cmd { my $mc = shift; return $mc->{cmd}; } sub orig { my $mc = shift; return $mc->{orig}; } sub end { my $mc = shift; $mc->{out}->("."); 1; } sub parse { my $mc = shift; my $regexp = shift; my $usage = shift; my @ret = ($mc->{cmd} =~ /$regexp/); $mc->parse_error($usage) unless @ret; my $i = 0; foreach (@ret) { $mc->{argn}[$i++] = $_; } return $mc; } sub arg { my $mc = shift; my $n = shift; # 1-based array, to correspond with $1, $2, $3 return $mc->{argn}[$n - 1]; } sub args { my $mc = shift; return @{$mc->{argn}}; } sub parse_error { my $mc = shift; my $usage = shift; $usage .= "\n" if $usage && $usage !~ /\n$/; die $usage || "Invalid syntax to '$mc->{base}' command\n" } sub no_opts { my $mc = shift; die "The '$mc->{base}' command takes no arguments\n" unless $mc->{cmd} eq $mc->{base}; return $mc; } 1; # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Perlbal-1.80/lib/Perlbal/Util.pm0000644000175000017500000000223211503530123016605 0ustar dormandodormando# misc util functions # package Perlbal::Util; use strict; use warnings; no warnings qw(deprecated); sub durl { my ($txt) = @_; $txt =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; return $txt; } =head2 C< rebless > Safely re-bless a locked (use fields) hash into another package. Note that for our convenience elsewhere the set of allowable keys for the re-blessed hash will be the union of the keys allowed by its old package and those allowed for the package into which it is blessed. =cut BEGIN { if ($] >= 5.010) { eval q{ use Hash::Util qw(legal_ref_keys unlock_ref_keys lock_ref_keys) }; *rebless = sub { my ($obj, $pkg) = @_; my @keys = legal_ref_keys($obj); unlock_ref_keys($obj); bless $obj, $pkg; lock_ref_keys($obj, @keys, legal_ref_keys(fields::new($pkg))); return $obj; }; } else { *rebless = sub { my ($obj, $pkg) = @_; return bless $obj, $pkg; }; } } 1; # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Perlbal-1.80/lib/Perlbal/UploadListener.pm0000644000175000017500000000513411503530123020626 0ustar dormandodormando###################################################################### # Listen for UDP upload status packets # # Copyright 2005-2007, Six Apart, Ltd. package Perlbal::UploadListener; use strict; use warnings; no warnings qw(deprecated); use base "Perlbal::Socket"; use fields qw(service hostport); # TCPListener sub new { my ($class, $hostport, $service) = @_; my $sock = IO::Socket::INET->new( LocalAddr => $hostport, Proto => "udp", ReuseAddr => 1, Blocking => 0, ); return Perlbal::error("Error creating listening socket: " . ($@ || $!)) unless $sock; my $self = fields::new($class); $self->SUPER::new($sock); $self->{service} = $service; $self->{hostport} = $hostport; $self->watch_read(1); return $self; } my %status; my @todelete; sub get_status { my $ses = shift; return $status{$ses}; } # TCPListener: accepts a new client connection sub event_read { my Perlbal::TCPListener $self = shift; my $buf; $self->{sock}->recv($buf, 500); return unless $buf =~ /^UPLOAD:(\w{5,50}):(\d+):(\d+):(\d+):(\d+)$/; my ($ses, $done, $total, $starttime, $nowtime) = ($1, $2, $3, $4, $5); my $now = time(); $status{$ses} = { done => $done, total => $total, starttime => $starttime, lasttouch => $now, }; # keep a history of touched records, then we'll clean 'em # after 30 seconds. push @todelete, [$now, $ses]; my $too_old = $now - 4; while (@todelete && $todelete[0][0] < $too_old) { my $rec = shift @todelete; my $to_kill = $rec->[1]; if (my $krec = $status{$to_kill}) { my $last_touch = $krec->{lasttouch}; delete $status{$to_kill} if $last_touch < $too_old; } } } sub as_string { my Perlbal::TCPListener $self = shift; my $ret = $self->SUPER::as_string; my Perlbal::Service $svc = $self->{service}; $ret .= ": listening on $self->{hostport} for service '$svc->{name}'"; return $ret; } sub as_string_html { my Perlbal::TCPListener $self = shift; my $ret = $self->SUPER::as_string_html; my Perlbal::Service $svc = $self->{service}; $ret .= ": listening on $self->{hostport} for service $svc->{name}"; return $ret; } sub die_gracefully { # die off so we stop waiting for new connections my $self = shift; $self->close('graceful_death'); } 1; # Local Variables: # mode: perl # c-basic-indent: 4 # indent-tabs-mode: nil # End: Perlbal-1.80/lib/Perlbal/Manual/0000755000175000017500000000000011722625030016555 5ustar dormandodormandoPerlbal-1.80/lib/Perlbal/Manual/LoadBalancer.pod0000644000175000017500000001045211516736504021604 0ustar dormandodormando=head1 NAME Perlbal::Manual::LoadBalancer - Using Perlbal as a Load Balancer =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION How to configure a Perlbal Load Balancing service. =head2 READ ME FIRST Please read L first for a better explanation on how to configure Perlbal. This document will make much more sense after reading that. =head2 Using Perlbal as a Load Balancer For a better understanding of how to set up Perbal as a Load Balancer, it should be noted that a Load Balancer and a Reverse Proxy can often be the same thing; not always, but often. A Load Balancer is a server (or device) that balances requests across a number of servers to spread the load. A Reverse Proxy can still do this but also have a number of other features. Perlbal as a Reverse Proxy provides features such as buffering content, preserving connections to the backend servers, starting connections ahead of time and a high priority queue, among others. You could almost say that a Load Balancer is a subset of a Reverse Proxy (it's not, but you could). When it comes to Perlbal, the Load Balancer is implemented as a Reverse Proxy without all the extra options, and that's why you set the role of a Load Balancer to C: SET role = reverse_proxy =head3 Simple load balancing Let's assume you want to configure two machines to serve your website and you want to let Perlbal decide how to balance the requests. For the sake of this exercise let's assume you have two servers at: 10.0.0.1:80 10.0.0.2:80 And now you want to use these two machines to serve your website at: 10.0.0.3:80 Here's a sample configuration to make this happen: CREATE POOL mywebsite POOL mywebsite ADD 10.0.0.1:80 POOL mywebsite ADD 10.0.0.2:80 CREATE SERVICE service_mywebsite SET role = reverse_proxy SET pool = mywebsite SET listen = 10.0.0.3:80 ENABLE service_mywebsite The first line defines a pool of machines called C. The second and third lines add your two machines to that pool (note that the indentation is not mandatory). After that you define a service called C with the role C set to listen on C<10.0.0.3:80> and using the pool C to serve the requests. The last line is what allows you have several services configured in a file even if they are not currently active (a common scenario is to configure everything on the file and then enable/disable services on-the-fly as required; see L for more information on this process). =head3 The Load Balancing algorithm Perlbal uses a highly efficient load balancing algorithm. It is very effective for distributing dynamic web requests among potentially heterogeneous hardware. First, backend servers must have their MaxClients (for apache, or equivalent) setting tuned to a reasonable limit. If your hardware can run 20 requests in parallel before running out of CPU, set MaxClients to 20. Next, by default Perlbal will distribute requests randomly. Opening a new connection to any available backend, and issuing the request. The proper algorithm is able to be used if C, C, C, and C are enabled. SET persist_backend = on SET verify_backend = on SET backend_persist_cache = 5 SET connect_ahead = 2 In this configuration, Perlbal will only route client requests to backends that it knows are real processes, instead of the OS listen queue. It will attempt to reuse pre-verified backends, and will attempt to create slightly more idle connections than it needs in preparation of future requests. When you put all this together, it becomes less likely that a client will wait for Perlbal to find an available backend. By setting your MaxClients properly, backends are able to serve traffic without getting overwhelmed. If no backends are available, Perlbal will queue them internally, rather than overload backends. You would want to disable C if you are balancing across image servers, or other extremely lightweight requests. =head2 SEE ALSO L, L, L, L. Perlbal-1.80/lib/Perlbal/Manual/ReverseProxy.pod0000644000175000017500000003364611630514744021761 0ustar dormandodormando=head1 NAME Perlbal::Manual::ReverseProxy - Configuring Perlbal as a Reverse Proxy =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION How to configure a Perlbal Reverse Proxy service. =head2 READ ME FIRST Please read L first for a better explanation on how to configure Perlbal. This document will make much more sense after reading that. =head2 Configuring Perlbal as a Reverse Proxy Configuration of Perlbal as a Reverse Proxy is similar to configuration as a Load Balancer. Check L under C for a sample configuration file and for a brief explanation of the differences between a Load Balancer and a Reverse Proxy. =head2 Parameters You can set parameters via commands of either forms: SET = SET = =over 8 =item B = bool Whether to trust all incoming requests' X-Forwarded-For and related headers. Set to true only if you know that all incoming requests from your own proxy servers that clean/set those headers. Default is false. =item B = int The number of backend connections to keep alive on reserve while there are no clients. Default is 2. =item B = bool Flag to disable any modification of X-Forwarded-For, X-Host, and X-Forwarded-Host headers. Default is false. =item B = size How much content-body (POST/PUT/etc) data we read from a client before we start sending it to a backend web node. If C is enabled, this value is used to determine how many bytes are read before Perlbal makes a determination on whether or not to spool the upload to disk. Default is 100k. =item B = size How much ahead of a client we'll get while copying from a backend to a client. If a client gets behind this much, we stop reading from the backend for a bit. Once all remaining data fits in the buffer, the backend is released and may be reused. Default is 256k. =item B = size How much ahead of a client we'll get while copying from a reproxied URL to a client. If a client gets behind this much, we stop reading from the reproxied URL for a bit. The default is lower than the regular C (50k instead of 256k) because it's assumed that you're only reproxying to large files on event-based webservers, which are less sensitive to many open connections, whereas the 256k buffer size is good for keeping heavy process-based free of slow clients. Default if 50k. =item B = int If an upload is coming in at a rate less than this value in bytes per second, it will be buffered to disk. A value of 0 means the rate will not be checked. Default is 0. =item B = size If an upload is larger than this size in bytes, it will be buffered to disk. A value of 0 means the size will not be checked. Default is 250k. =item B = int If an upload is estimated to take more than this number of seconds, it will be buffered to disk. A value of 0 means the time will not be estimated. Default is 5. =item B = bool Used to enable or disable the buffer uploads to disk system. If enabled, C bytes worth of the upload will be stored in memory. At that point, the buffer upload thresholds will be checked to see if we should just send this upload to the backend or if we should spool it to the disk. Default if false. =item B = path/to/directory Directory root for storing files used to buffer uploads. =item B = I How large to set the client's socket SNDBUF. Default is 0. =item B = int How many extra backend connections we keep alive in addition to the current ones, in anticipation of new client connections. Default is 0. =item B = bool Whether Perlbal should transparently retry requests to backends if a backend returns a 500 server error. Default is false. =item B = bool Enable 'reproxying' (end-user-transparent internal redirects) to either local files or other URLs. When enabled, the backend servers in the pool that this service is configured for will have access to tell this Perlbal instance to serve any local readable file, or connect to any other URL that this Perlbal can connect to. Only enable this if you trust the backend web nodes. Default is false. See the section C in this document for more information. =item B = string of comma-separated seconds (full or partial) String of comma-separated seconds (full or partial) to delay between retries. For example "0,2" would mean do at most two retries, the first zero seconds after the first failure, and the second 2 seconds after the second failure. You probably don't need to modify the default value. Default it 0,0.25,0.50,1,1,1,1,1 =item B = bool Enable SSL to the client. Default is false. =item B = cookie_name The cookie name to inspect to determine if the client goes onto the high-priority queue. See L for more information. =item B = string A string that the C must contain to go onto the high-priority queue. See L for more information. =item B = int Timeout in seconds for idle connections to the end user. It's also the limit for how long a backend may take to respond or transfer data. Default is 30. =item B = ip:port The ip:port to listen on. For a service to work, you must either make it listen, or make another selector service map to a non-listening service. =item B = int The maximum number of requests to be made on a single persistent backend connection before releasing the connection. A value of 0 means there is no limit and the connection will only be discarded once the backend asks it to be or when Perlbal is sufficiently idle. Default is 0. =item B = size The maximum size that will be accepted for a chunked request (which is written to disk, buffered uploads must be on). A value of 0 means no limit. Default is 209715200 (200MB). =item B = bool Whether to enable HTTP keep-alives to the end user. Default is false. =item B = bool Whether to enable HTTP keep-alives to the backend webnodes. Default is false, but setting it to true is highly recommended if Perlbal is the only client to your backends. If not, beware that Perlbal will hog the connections, starving other clients. =item B = int Timeout in seconds for HTTP persist_client_idle_timeout keep-alives to the end user. Default is 30. =item B = int (B) Set both the persist_client_timeout persist_client_idle_timeout and idle_timeout. Deprecated. =item B Name of previously-created pool object containing the backend nodes that this reverse proxy sends requests to. =item B = int:0-100 Chance (percentage) to take a standard priority request when we're in pressure relief mode. Default is 0. See L for more information. =item B = int Number of outstanding standard priority connections to activate pressure relief at. A value of 0 disables the high priority queue system entirely. Default is 0. See L for more information. =item B = int Set the maximum number of cached reproxy results (X-REPROXY-CACHE-FOR) that may be kept in the service cache. These cached requests take up about 1.25KB of RAM each (on Linux x86), but will vary with usage. Perlbal still starts with 0 in the cache and will grow over time. Be careful when adjusting this and watch your RAM usage like a hawk. Default is 0, which means cache is disabled. =item B = reverse_proxy|web_server|management|selector What type of service. One of 'reverse_proxy' for a service that load balances to a pool of backend webserver nodes, 'web_server' for a typical webserver', 'management' for a Perlbal management interface (speaks both command-line or HTTP, auto-detected), or 'selector', for a virtual service that maps onto other services. =item B Executable which will be the HTTP server on stdin/stdout. (B, B) =item B = path/to/file Path to certificate PEM file for SSL. Default is C. =item B = cipher list OpenSSL-style cipher list. Default is C. =item B = path/to/file Path to private key PEM file for SSL. Default is C. =item B = Net::Netmask filter A comma separated list of L filters (e.g. 10.0.0.0/24, see L) that determines whether upstream clients are trusted or not, where trusted means their X-Forwarded-For/etc headers are not munged. =item B = comma separated list of hosts Comma separated list of hosts in form 'a.b.c.d:port' which will receive UDP upload status packets no faster than once a second per HTTP request (PUT/POST) from clients that have requested an upload status bar, which they request by appending the URL get argument ?client_up_sess=[xxxxx] where xxxxx is 5-50 'word' characters (a-z, A-Z, 0-9, underscore). =item B = bool Whether Perlbal should send a quick OPTIONS request to the backends before sending an actual client request to them. If your backend is Apache or some other process-based webserver, this is highly recommended. All too often a loaded backend box will reply to new TCP connections, but it's the kernel's TCP stack Perlbal is talking to, not and actual Apache process yet. Using this option reduces end-user latency a ton on loaded sites. Default if false. =item B = path What path the OPTIONS request sent by C should use. Default is C<*>. =item B = bool Whether to provide a "Server" header. Perlbal by default adds a header to all replies (such as the web_server role). By setting this default to "off", you can prevent Perlbal from identifying itself. Default is C. =back =head2 More on Parameters =head3 backend_persist_cache vs. connect_ahead The C parameter refers to connections kept alive after being used, while C refers to connections opened in anticipation. For instance: SET backend_persist_cache = 2 SET connect_ahead = 1 Let's assume, for simplification purposes, that your service only has one server. Here's an example of what could happen: =over 4 =item * Perlbal starts No connections open until the very first request comes in (this may change in the future). =item * one requests arrives This request starts being served on the open connection; Perlbal opens another connection because C's value tells it to always open one in anticipation. =item * a second request arrives (the first request hasn't concluded yet) The second connection is used, a third one is created so we still have one in anticipation. =item * the first request finishes The connection is kept open; this means we now have three open connections: two being used and one free (the first and the third one are free). =item * the second request finishes The connection is killed, as we already have two other open connections (the first and the third), and that's the number set by C for the number of connections to be kept alive. =back =head3 Reproxying Perlbal supports the concept of reproxying. Basically, this gives it the ability to ask a backend node for a file and get back a specific header that says "this file is really over there, get it there." Perlbal will then load that file or URL and send it to the user transparently, without them ever knowing that they got reproxied to another location. Add the following line to your F to enable reproxying on a per service basis ( reproxying is disabled by default in >= 1.38 ): SET enable_reproxy = true This can be useful for having URLs that get mapped to files on disk without giving users enough information to map out your directory structure. For example, you can create a file structure such as: /home/pics/$userid/$pic Then you can have URLs such as: http://foo.com/mysite/users/$userid/picture/$pic When this URL gets passed to the backend web node, it could return a simple response that includes this header: X-REPROXY-FILE: /home/pics/$userid/$pic Perlbal will then use asynchronous IO to send the file to the user without slowing down Perlbal at all. This support also extends to URLs that can be located anywhere Perlbal has access to. It's the same syntax, nearly: X-REPROXY-URL: http://foo.com:80/resource.html You can also specify multiple URLs: X-REPROXY-URL: http://foo.com:80/resource.html http://baz.com:8080/res.htm Just specify any number of space separated URLs. Perlbal will request them one by one until one returns a response code of 200. At that point Perlbal will proxy the response back to the user just like normal. Note that the user's headers are NOT passed through to the web server. To the target server, it looks simply like Perlbal is requesting the resource for itself. This behavior may change at some point. One final note: the server that returns the reproxy header can also return a C header. If present, Perlbal will consider a reproxy a failure if the file returned by the target system is of a different size than what the expected size header says. On failure, Perlbal tries the next URI in the list. If it's a file being reproxied, a 404 is returned if the file size is different. =head2 SEE ALSO L, L, L, L. Perlbal-1.80/lib/Perlbal/Manual/Roles.pod0000644000175000017500000000166711516736504020371 0ustar dormandodormando=head1 NAME Perlbal::Manual::Roles - Roles supported by Perlbal =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION Brief description of Perlbal's roles. =head2 Available Roles =head3 management Used to set a management service (a port you can telnet to and issue configuration/debugging commands to). See L for more information. =head3 reverse_proxy Used for reverse proxy and load balancing. See L and L for more information. =head3 selector A virtual service that maps onto other services. See L for more information. =head3 web_server Used to set Perlbal as a web server. See L for more information. =head2 SEE ALSO L, L, L, L, L. Perlbal-1.80/lib/Perlbal/Manual/Management.pod0000644000175000017500000003426511516736504021361 0ustar dormandodormando=head1 NAME Perlbal::Manual::Management - Managing Perlbal on-the-fly =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION How to configure a Perlbal C service for on-the-fly configuration and debugging. =head2 READ ME FIRST Please read L first for a better explanation on how to configure Perlbal. This document will make much more sense after reading that. =head2 Setting up a management service You can create a management service in the following way: CREATE SERVICE mgmt SET role = management SET listen = 127.0.0.1:16000 ENABLE mgmt =head3 Consulting information with a browser If you access the management service (in this case, 127.0.0.1 on port 16000) with a browser you'll reach a page with information on the services that are enabled. You're also able to click those services and reach further information on each of them. =head3 Managing Perlbal via telnet If you telnet to the management service you get a connection that allows you manage your Perlbal's instance. $ telnet 127.0.0.1 16000 Trying 127.0.0.1... Connected to 127.0.0.1. Escape character is '^]'. You now have access to several commands (which are case insensitive): =head4 Admin Commands =over 4 =item create pool =item create service Creates a pool or a service. create pool my_new_pool create service my_new_service =item disable Disables a service (stops listening). disable my_service Note that you can not disable C services. =item enable Enables a service (starts listening). enable my_service =item header insert
: =item header remove
Inserts or removes headers from the request before they're passed on to the backend. When adding headers you must state the value: header my_service insert x-myamazingheader:myamazingvalue When removing headers you don't need the state any value, the header will be removed regardless of the value it holds: header my_service remove Connection Note: the usage of C in the beginning of your header is not required, but the convention is that non-standard headers be prefixed with C. =item load Loads a Perlbal plugin. load AccessControl =item plugins Lists plugins =item pool add =item pool remove Allows you to add or remove nodes from a service. pool add my_service 127.0.0.1:1337 pool remove my_service 127.0.0.1:1337 Note that adding a node that already exists or removing a non-existing node do not result in an error message. Also note that the port number defaults to :80 if omitted. =item reproxy_state Dumps the state of reproxy status. reproxy_state SERVER max_reproxy_connections = 0 =item server = Sets a server parameter, where param is one of: =over 8 =item * max_reproxy_connections = Maximum number of concurrent connections to the backends. =item * max_reproxy_connections(C) = Maximum number of concurrent connections to one specific backend. =item * max_connections = Sets the value of C (maximum number of open files for this process). Requires L. Also, Perlbal must be run under a superuser. =item * nice_level = Sets the C level for the process. =item * aio_mode = One of C, C for L, or C for L. This controls how disk IO is done asynchronously. Highly recommended to use L or L for webserving or reproxying files. For purely reverse proxy or only reproxying URLs, none is fine. =item * aio_threads = Number of child threads doing disk IO. Use between 2 and 50. =item * track_obj = Developer option to track objects. =item * pidfile = Filename to write pidfile to (no pidfile if not specified). =item * crash_backtrace = 1 or 0 indicating whether to perform a backtrace while the server is crashing. =back =item set [] = Sets a property on a pool. If the pool was just created, specifying the pool name is optional. Setting the file to autoload nodes from (Perlbal will periodically check the file for updates): SET my_pool nodefile = /path/to/file Unsetting the file to autoload nodes from (note that this does not remove current members): SET my_pool nodefile = none C, C, "" and '' are interpreted just like C. Note that manually modifying the pool (via POOL ADD or POOL REMOVE) will disable the periodic checking of the nodefile. Setting the load balancing method: SET pool balance_method = 'random' Yes, we do realize that C is the only method currently available, but hey. =item set [] = Sets a property on a service. If the service was just created, specifying the service name is optional. See L, L and L for the list of available parameters. =item show service [] =item show pool [] List all services: show service Show details of a service: show service my_service Lists all pools, nodes and services using them: show pool Show the members of a pool: show pool my_pool =item shutdown [graceful] Shuts down the server (you'll also lose your telnet session). Can be used instantly, killing all active connections: shutdown Using the parameter C listening sockets are closed and perlbal stays alive until clients bleed off. shutdown graceful =item unload Unloads a plugin. unload AccessControl =item use =item use Sets the implied service or pool for future operations. For instance, after: use my_pool You can just type: pool add 127.0.0.1:6000 Note that creating a service or pool also sets it as the implied service. =item xs =item xs [enable ] =item xs [disable ] Show status of XS modules loaded: xs Turn on an already-loaded XS module: xs enable module_name Turn off an already-loaded XS module: xs disable module_name =back =head4 Diagnostic Commands =over 4 =item aio Shows L stats. =item backends Lists the open connections to the backends. backends 127.0.0.1:3080 1 127.0.0.1:3081 2 In the above example, there are 3 open connections (they may be being used or they may simply be open according to the value of C). =item dumpconfig Shows the current configuration for each service. If a service uses a plugin that supports C, that plugin's configuration is also dumped (see C under L for more information). =item fd Shows the maximum number of file descriptors and how many are currently in use. fd max 1024 cur 8 =item gladiator Requires L. Iterate's Perl's internal memory structures and can be used to enumerate all the currently live SVs. This can be used to hunt leaks and to profile memory usage. =item help Displays the list of available commands. =item leaks =item leaks Iterates over active objects. If an argument is specified, it is treated as code with C<$_> being the reference to the object. Shows objects that might have been leaked. =item mime Lists known mime types. mime css text/css doc application/msword ... =item node Dumps information on a specific node. node 127.0.0.1:8181 127.0.0.1:8181 attempts 10 127.0.0.1:8181 lastattempt 1290461126 Calling C with a parameter is the same as calling C. =item nodes Dumps information on all nodes. nodes 127.0.0.1:8181 attempts 10 127.0.0.1:8181 lastattempt 1290461126 127.0.0.1:8081 connects 19 127.0.0.1:8081 lastconnect 1290461127 127.0.0.1:8081 attempts 19 127.0.0.1:8081 responsecodes 200 11 127.0.0.1:8081 lastattempt 1290461127 =item noverify Shows the amount of time left for each node marked as noverify. If the C parameter is set to a true value, perlbal tries to send an C command to a node before sending it the actual client request. If the node doesn't support the C command, the node is added to an internal hash so that an C command is not issued for new requests during the next 60 seconds. noverify 127.0.0.1:8081 42 In the above example, node 127.0.0.1:8081 is on that list and still has 42 seconds until an C command is tried again. If the time is a negative value it means that the C command will be issued before the next request. =item obj Shows objects count in scope. The environment variable C must be set to a true value (see C under L for more information). =item pending Shows pending backend connections by service, node, and age. =item proc Shows CPU usage, current time, pid, and total requests processed. =item prof on =item prof off =item prof data Enables/disables profiling or dumps profile data. =item queues Shows status of all queues (normal, high priority and low priority) for all enabled services. queues service_mywebsite-normal.age 1 service_mywebsite-normal.count 8 service_mywebsite-highpri.age 0 service_mywebsite-highpri.count 0 service_mywebsite-lowpri.age 0 service_mywebsite-lowpri.count 0 =item reload Reloads a plugin that supports reloading. =item socks [all] =item socks summary Lists all sockets or shows a summary of the sockets (by default lists all sockets). socks fd age 3 748s Perlbal::ClientManage(R): open to 85.245.86.253:52248 4 1003s Perlbal::TCPListener(R): open: listening on 82.102.30.112:80 for service 'ws' 6 1003s Perlbal::TCPListener(R): open: listening on 0.0.0.0:60000 for service 'mgmt' socks summary 1 Perlbal::ClientManage 2 Perlbal::TCPListener Aggregate write buffer: 0.0k Open files: 0 =item state changes Lists recent state changes of requests. For instance, while a request is being processed this command may issue something like: state changes Perlbal::ClientProxy=HASH(0x12d7ec28): reading_headers, wait_backend, backend_req_sent, wait_res Perlbal::BackendHTTP=HASH(0x12d75f30): connecting, bored, sending_req, wait_res wait_res 2 And as soon as the request is processed: state changes Perlbal::BackendHTTP=HASH(0x12d75f30): connecting, bored, sending_req, wait_res, xfer_res, closed closed 1 Note: This functionality depends on the environment variable C being set to a true value. =item states =item states Shows how many sockets of which type and in which state currently exist for all services. states Perlbal::ClientProxy draining_res 1 If a service is specified, shows the information for that service only. states ws Perlbal::BackendHTTP wait_res 1 Perlbal::ClientProxy wait_res 1 =item track Dumps objects tracked, sorted by age. track 15s Perlbal::HTTPHeaders=HASH(0x1a043a50): Perlbal::HTTPHeaders::clone, Perlbal::BackendHTTP::assign_client, Perlbal::Service::register_boredom, Perlbal::BackendHTTP::event_write, Danga::Socket::EpollEventLoop, (eval), Perlbal::run 15s Perlbal::HTTPHeaders=HASH(0x19594fe0): Perlbal::HTTPHeaders::new, Perlbal::Socket::read_headers, Perlbal::Socket::read_response_headers, Perlbal::BackendHTTP::event_read_waiting_options, Perlbal::BackendHTTP::event_read, Danga::Socket::EpollEventLoop, (eval), Perlbal::run 15s Perlbal::HTTPHeaders=HASH(0x1a043d80): Perlbal::HTTPHeaders::new, Perlbal::Socket::read_headers, Perlbal::Socket::read_response_headers, Perlbal::BackendHTTP::event_read, Danga::Socket::EpollEventLoop, (eval), Perlbal::run 15s Perlbal::BackendHTTP=HASH(0x1a044608): Perlbal::BackendHTTP::new, Perlbal::Service::spawn_backends, Perlbal::Service::note_bad_backend_connect, Perlbal::BackendHTTP::event_err, Danga::Socket::EpollEventLoop, (eval), Perlbal::run 15s Perlbal::BackendHTTP=HASH(0x1a042588): Perlbal::BackendHTTP::new, Perlbal::Service::spawn_backends, Perlbal::Service::note_bad_backend_connect, Perlbal::BackendHTTP::verify_failure, Perlbal::BackendHTTP::event_read_waiting_options, Perlbal::BackendHTTP::event_read, Danga::Socket::EpollEventLoop, (eval), Perlbal::run 15s Perlbal::BackendHTTP=HASH(0x1a044488): Perlbal::BackendHTTP::new, Perlbal::Service::spawn_backends, Perlbal::Service::request_backend_connection, Perlbal::ClientProxy::request_backend, Perlbal::ClientProxy::handle_request, Perlbal::ClientProxy::event_read, Danga::Socket::EpollEventLoop, (eval), Perlbal::run For this to work you must have the environment variable C set to a true value and the server option C on: server track_obj = 1 OK =item uptime =item version Shows the time the server was started, the current uptime and Perlbal's version. =item varsize Debug management command to track size of internal data structures. varsize svc-ws-bored_backends [] 2 svc-ws-pending_connects {} 2 {127.0.0.1:3080} = {127.0.0.1:3081} = Perlbal::BackendHTTP=HASH(0x1cfd2490) =item verbose on =item verbose off Turns verbose mode on or off. verbose on load AccessControl OK verbose off load AccessControl verbose on OK load AccessControl OK Yes, verbose mode only activates the printing of an OK message upon completion of some commands such as C. Errors are displayed regardless of verbose status. =back =head2 CAVEAT Note that this functionality doesn't implement any sort of authentication. If you can telnet to the address you specify, you can access the information and change things on the fly. Some alternatives to authentication are commonly employed: =over 4 =item * specifying the address as being 127.0.0.1 means that no one outside the machine can telnet to the management service; =item * setting the management address as a private IP available only through a VPN, for instance, will allow you to manage these accesses on the VPN instead. =back =head2 SEE ALSO L, L. Perlbal-1.80/lib/Perlbal/Manual/Logging.pod0000644000175000017500000001201111516736504020654 0ustar dormandodormando=head1 NAME Perlbal::Manual::Logging - How Perlbal's logging system works =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION Perlbal supports logging of a few messages (and you can log your messages in your plugins, for instance). This document describes how to achieve that. =head2 IMPORTANT: foreground vs. background If Perlbal is running on the foreground, it logs by calling C, which means you should get the logs on C. If Perlbal is running on the background, it logs through L. If L is not available, there will be no logging, and THAT'S THE MOST IMPORTANT THING TO KNOW ABOUT PERLBAL'S LOGGING SYSTEM. =head2 How to log a message You can log a message by calling C as you'd call L's C: Perlbal::log( $priority, $format, @args ); You should read the documentation for L for more information, but here's an example: Perlbal::log( 'info', 'beginning run' ); And here's another example: Perlbal::log( 'crit', "this thing crashed: $!" ); =head2 What is logged? =over 4 =item * When we try to read from or write to a filehandle that is undefined, L logs a critical message: Perlbal::log("crit", "Undef \$fh: $stack_trace"); =item * When failing to create a socket, L logs a critical message: Perlbal::log('crit', "Error creating socket: $!"); =item * When C fails to create a socket, L logs a critical message: Perlbal::log('crit', "inet_aton failed creating socket for $ip"); =item * When writing to a client, if we try to read more than we should from the backend, L logs a warning message: Perlbal::log('warning', "tried to readahead negative bytes. filesize=$self->{reproxy_file_size}, offset=$self->{reproxy_file_offset}"); =item * When opening a file being PUT for writing to disk, if there's an error (which is going to originate a 500 server error), L logs a warning message: Perlbal::log('warning', "system error: $msg ($info)"); =item * If we receive a request with a content lenght different from the actual length of the request, L logs a critical message: Perlbal::log('crit', "Content length of $clen declared but $self->{buoutpos} bytes written to disk"); =item * When trying to buffer data to disk, if the operation fails L logs a critical message: Perlbal::log('crit', "Failure to open $fn for buffered upload output"); =item * After buffering data to disk, if the file is empty, L logs a critical message: Perlbal::log('crit', "Error writing buffered upload: $!. Tried to do $len bytes at $self->{buoutpos}."); =item * When purging a buffered upload on the disk, if an error occurs, L logs a critical message: Perlbal::log('warning', "Unable to link $self->{bufilename}: $!"); =item * When marking a backend as pending, if there's already another one in that ip/port, L will log a couple of warning messages: Perlbal::log('warning', "Warning: attempting to spawn backend connection that already existed."); Perlbal::log('warning', " -- [$filename:$line] $package::$subroutine"); =item * When deciding whether we should spawn one or more backend connections, if the total of pending conections is negative, L will log a critical message: Perlbal::log('crit', "Bogus: service $self->{name} has pending connect count of $self->{pending_connect_count}?! Resetting."); =item * When spawning a backend connection, if there is no IP address for the backend, L will log a critical message: Perlbal::log('crit', "No backend IP for service $self->{name}"); =item * When starting, L will log an info message: Perlbal::log('info', 'beginning run'); =item * When shutting down, L will log an info message: Perlbal::log('info', 'ending run'); =item * After each loop, is some error occurred, L will log a critical message: Perlbal::log('crit', "crash log: $_") foreach split(/\r?\n/, $@); =item * When attempting to create the pidfile, if unsuccessful, L will log an info message: Perlbal::log('info', "couldn't create pidfile '$file': $!" ); =item * When attempting to write to the pidfile, if unsuccessful, L will log an info message: Perlbal::log('info', "couldn't write into pidfile '$file': $!" ); =back =head2 Generating more logs by sending a USR1 signal to perlbal If you send a USR1 signal to perlbal, that tells it to log some basic statistics to the syslog. It's similar to connecting to a management service and issue a C for each service, plus a C and a C commands. =head2 Where is it logged to? The way Perlbal opens L, it logs to F by default. =head2 SEE ALSO You can tweek L's configuration under F. See L for more details. Perlbal-1.80/lib/Perlbal/Manual/Debugging.pod0000644000175000017500000002047111516736504021172 0ustar dormandodormando=head1 NAME Perlbal::Manual::Debugging - Debugging Perlbal =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION Perlbal has two ways of debugging. One of them is through a management console; the other is through debugging messages. =head2 Debugging in a console You'll need to set up a management service and use it to dump all the information you require. The comprehensive documentation on this process can be found at L. =head2 Debugging messages You can control the ammount of debugging messages Perlbal dumps by setting the environment variable C to a value between 0 and 4: PERLBAL_DEBUG = 0 # no debug PERLBAL_DEBUG = 4 # debug everything =head3 Debug level 1 You can activate basic debug by setting C to 1: PERLBAL_DEBUG = 1 The following debugging messages are turned on: =over 4 =item * When a connection to a backend is closed, L prints C =item * When a connection to a backend is killed, L prints C =item * When an HTTP request fails to be parsed, L prints C =item * When the connection is promoted to SSL, L prints C< .. socket upgraded to SSL!> =back =head3 Debug level 2 By setting the debug level to 2 you'll get all the messages from level 1. PERLBAL_DEBUG = 2 You will also get a few others: =over 4 =item * When a connection to a backend is opened and ready to be written to, L prints C =item * When a response is about to be handled, L prints C =item * When a backend is ready to be read from, L prints C =item * When there's an error with the connection to the backend, L prints C =item * Whenever we're determining if we should be sending keep-alive header information back to the client, L prints C =item * Whenever the client is ready for more of its file, L prints C =item * Right after we've read a chunk of a file and when a reproxy request is about to be sent, L prints C =item * When we've written all data in the queue (and are about to stop waiting for write notifications), L prints C =item * Whenever a client proxy is about to be closed, L prints C, followed by a possible C and a possible C =item * When a client has disconnected, L prints C =item * When a backend requests a client of a high priority request and the client is available, L prints C =item * When a backend requests a client of a normal priority request and the client is available, L prints C{fd}.> =item * When a backend requests a client of a low priority request and the client is available, L prints C{fd}.> =item * When header are being read, L prints C =back =head3 Debug level 3 PERLBAL_DEBUG = 3 By setting the debug level to 3 you'll get all the messages from level 1 and 2 plus the following: =over 4 =item * Right before response headers are written to the client, L prints C< writing response headers to client> =item * As we're writing to the client, L prints C< content_length=VALUE> and C< remain=VALUE>, where the values are C if they are not defined =item * If we're done writing to the client, L prints C< done. detaching.> =item * Whenever we're determining if we should be sending keep-alive header information back to the client, L prints C< service's persist_client = $persist_client> =item * While determining if we should be sending keep-alive header information back to the client, if we were sent C or it's a head request, as we're doing a keep alive L prints C< doing keep-alive to client> =item * If we're not sending keep-alive header information back ot the client, L prints C< doing connection: close> =item * Right after we've finished sending all of the results to the user, L prints C =item * When we've sent a response to a user fully and we need to reset state, L prints C =item * When we're writing a response to a client, L prints C =item * After writing a response to a client, if it is still connected and we're triggering trigger our backend to keep reading, L prints C< unstalling backend> =item * When reading a request, L prints C =item * When reading a request and just before we read the headers, L prints C< no headers. reading.> =item * When reading a request, if we're not buffering to disk or we're no longer reading, as we disable reads, L prints C< disabling reads.> =item * As we're reading, L prints C< reading $read_size bytes (VALUE bytes remain)>, where C can be =item * After each read, L prints C< read $len bytes> =item * After we finished reading the request, L prints C< done_reading = $done_reading, backend = BACKEND>, where C can be C =item * When we send the headers to the backend and it responds before we're done reading from the client, further reads from the client are discarded; in this situation L prints C< already responded.>. If the client continues to send data, L prints C< already responded [2].> and then gives up on reading =item * After reading, and having a backend available where we can write to, just before we do, L prints C< got a backend. sending write to it.> =item * After reading, if there's no backend available, L prints C< no backend. read_ahead = $self->{read_ahead}.> =item * If we know we've already started spooling a file to disk and we're about to continue doing so, L prints C< bureason = $self->{bureason}> =item * If a backend wasn't available and we're about to request one, L prints C< finally requesting a backend> =item * When we're trying to read headers and the client has disconnected, L prints C< client disconnected> =item * If we need to remove a trailing C<\r\n> from the headers, L prints C< throwing away leading \r\n> =item * If we've read a packet with headers and by the end of it we can't find the end of them, L prints C< can't find end of headers> =item * Once we've read some headers, L prints C< pre-parsed headers: [$hstr]> =item * After reading headers, if there's additional content that we've read, we push it back; when we do so, L prints C< pushing back $len bytes after header> =item * If we got bogus headers, and right before we close the connection due to a parsing failure, L prints C< bogus headers> =item * If we got valid headers, L prints C< got valid headers> =item * If we're reading buffered data from a client, L prints C =back =head3 Debug level 4 By setting the debug level to 4 you get all the messages from levels 1 to 3. Plus, C is redefined so that whenever C is called it first prints C$clenE"$content") from ($pkg, $filename, $line)>. PERLBAL_DEBUG = 4 =head2 SEE ALSO L, L. Perlbal-1.80/lib/Perlbal/Manual/Install.pod0000644000175000017500000001573711516736504020716 0ustar dormandodormando=head1 NAME Perlbal::Manual::Install - Steps, dependencies and requirements to install Perlbal =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION How to install Perlbal. =head2 Installing Perlbal for the impatient $ perl -MCPAN -e shell cpan> install Perlbal L is also good at quickly installing Perlbal and all of its dependencies $ cpanm Perlbal IO::AIO Perlbal::XS::HTTPHeaders ... will give you an ideal Perlbal environment. =head2 Installing Perlbal (with a little more detail) You need to have perl on the machine. If you don't have it yet, you can grab it from http://www.perl.org/. Having perl on the machine should give you access to the CPAN shell, one of several possible ways to install and upgrade Perl modules. Start your CPAN shell: $ perl -MCPAN -e shell And now tell it to install Perlbal: cpan> install Perlbal In the end you should see a message stating "make install -- OK" (if that's not the case, please refer to section Troubleshooting later in this document). =head2 Installing Perlbal by hand (without using the CPAN shell) Head to L and find the download link. Download the file and untar it: $ tar zxvf Perlbal-X.XX.tar.gz Note that X.XX stands for the version number. Replace that with the latest version you got. Now you need to create the Makefile and run it; we're also going to run the tests before installing Perlbal: $ cd Perlbal-X.XX.tar.gz $ perl Makefile.PL $ make $ make test $ sudo make install =head2 Installing the latest development version You can clone Perlbal's repository from github and install it by hand by following the next steps: $ git clone http://github.com/perlbal/Perlbal.git $ cd Perlbal $ perl Makefile.PL $ make $ make test $ sudo make install =head2 Optional Dependencies and Asynchronous IO It is very highly recommended that L is installed and enabled. If you have poor performance, the first thing to do is install L. $ perl -MCPAN -e shell cpan> install Perlbal::XS::HTTPHeaders Enable it in your configuration: XS enable headers Perlbal checks for L availability and uses it to perform asynchronous IO operations. If you're performing disk operations (e.g., using Perlbal as a web server), having L will improve your response times. The only thing required in order to benefit from this feature is to install L: $ perl -MCPAN -e shell cpan> install IO::AIO If you don't have L installed a warning message will be displayed when you start perlbal: WARNING: AIO mode disabled or not available. Perlbal will run slowly under load if you're doing any disk operations. (e.g. web_server mode). Install IO::AIO for better performance. =head2 Checking that Perlbal is succesfully installed Perlbal is shipped with some sample configuration files that reside in the F directory (of the source). You can give Perlbal a try by heading to the directory where the source is and using the following command: $ sudo perlbal -c conf/webserver.conf By pointing your browser at C you should now see Perlbal responding (showing you the contents of C). Note that the F file sets up a Perlbal web server that listens on port 80. If you already have something listening on port 80 you need to either stop that service or change the port number on F. Also note that if your machine doesn't have a C directory you'll see an C error message. Change the directory in the configuration file to something that exists. =head2 Troubleshooting =head3 Prerequisites not found If you're installing Perlbal by hand you may encounter some error messages describing how some prerequisites are not available: user@machine:~/Perlbal-X.XX$ perl Makefile.PL Checking if your kit is complete... Looks good Warning: prerequisite BSD::Resource 0 not found. Warning: prerequisite Danga::Socket 1.44 not found. Warning: prerequisite HTTP::Date 0 not found. Warning: prerequisite HTTP::Response 0 not found. Warning: prerequisite Sys::Syscall 0 not found. Writing Makefile for Perlbal This is perl's way of telling you that since you're installing Perlbal by hand you'll also need to install its prerequisites by hand. Your first choice is to download each of them separately and perform the same installation procedure for each. Unfortunately, they are all likely to have additional prerequisites. Recursively. Alternately, see the following Troubleshooting item: C. =head3 No connection to the internet If you don't have a connection to the internet you can still install Perlbal, but you'll have to tranfer the source somehow to the machine. Given that Perlbal has other module dependencies from CPAN (and those have their own dependencies too), here's a solution for this problem: Step 1: On a machine with connection to the internet, install CPAN::Mini: $ perl -MCPAN -e shell cpan> install CPAN::Mini Run C to create a minimal CPAN mirror (it contains only the latest version of each module): $ minicpan -l /home/user/minicpan/ -r http://cpan.org/ Now grab that directory and record it to something you can read on the other machine (e.g., a DVD, a hard drive). Once you're on that machine, you can run the CPAN shell and tell it to look for distributions on the local directory where you now have your own CPAN mirror: $ perl -MCPAN -e shell cpan> o conf urllist push file:///home/user/path/to/minicpan cpan> install Perlbal If you want C to record this change don't forget to commit: cpan> o conf commit =head3 No compiler available If there's no compiler available on the machine you will probably see an error ending in something like: Failed during this command: DORMANDO/Perlbal-X.XX.tar.gz : writemakefile NO '/usr/bin/perl Makefile.PL INSTALLDIRS=site' returned status -1 You need to install something like C (check L). After installing C, when trying to install Perlbal again you may get another error message: cpan> install Perlbal Running install for module 'Perlbal' Running make for D/DO/DORMANDO/Perlbal-X.XX.tar.gz Has already been unwrapped into directory /home/myself/.cpan/build/Perlbal-X.XX-GFko0J '/usr/bin/perl Makefile.PL INSTALLDIRS=site' returned status -1, won't make Running make test Make had some problems, won't test Running make install Make had some problems, won't install This is the cpan shell assuming nothing changed in the system and skipping a few steps. You need to let it know you're willing to forget the past: cpan> look Perlbal $ rm -rf * $ exit And now you can try installation again: cpan> install Perlbal =head2 SEE ALSO L. Perlbal-1.80/lib/Perlbal/Manual/Plugins.pod0000644000175000017500000004004511720322461020705 0ustar dormandodormando=head1 NAME Perlbal::Manual::Plugins - Creating and using plugins =head2 VERSION Perlbal 1.78. =head2 DESCRIPTION How to create and use Perlbal plugins. =head2 How to use a plugin Perlbal supports plugins through modules under C that implement a set of functions described further down this document. Some of these plugins are shipped with Perlbal itself, while others can be found on CPAN (you can also create your own plugin and have it available only locally). In order to use a plugin you first have to load it; on your Perlbal's configuration file add something like: Load MyPlugin This loads plugin C. Each plugin will have its own way of being configured (some don't require any configuration at all), so you'll have to refer to their documentation (or code). Typically (but not always), a plugin will allow you to set additional parameters to a service; for instance: LOAD MaxContentLength CREATE SERVICE example SET max_content_length = 100000 SET plugins = MaxContentLength C is a parameter of L. If you're worried that two plugins may have the same parameter, of if you simply want to define those variables all in the same spot and thus will be doing it outside of the plugin's context, you can use the more verbose syntax: SET my_service.my_plugin.my_variable = my_value Notice that some plugins need to be stated service by service; hence, this line: SET plugins = MaxContentLength The C parameter (a list of strings separated by commas or spaces) defines which plugins are acceptable for a service. =head3 Troubleshooting If you try to load a plugin and receive the following error message: ERROR: Can't locate Perlbal/Plugin/MyPlugin.pm in @INC That means that either the plugin isn't installed or perlbal couldn't find it. (perhaps it is installed in a different version of perl other than the one used to run perlbal?) =head2 How to create a plugin A Perlbal plugin consists in a package under the C namespace that implements a number of functions: C, C, C and C. These steps and functions (plus some helper functions you can define or use) are described below. PLEASE KEEP IN MIND: Perlbal is a single-process, asynchronous web server. You must not do things in plugins which will cause it to block, or no other requests can be served at the same time. =head3 Creating a package While there are many ways of creating a package, we'd recommend that you use something to do it for you. A good option is L. (note: if you really want to, you can just create a file with your package and use it; by using something like L you're making sure that several pitfalls are avoided, lots of basic rules are followed and that your package can easily be made available as a distribution that you can deploy on any machine - or, if you feel so inclined, upload to CPAN - in a simple way) Let's assume you want to create a plugin that checks requests for a C header and, if present, add an header C to the response when serving a file. Let's assume your plugin will be called C. Having installed L, here's a command you can run that will create your package for you: $ module-starter --module=Perlbal::Plugin::ColorOfMagic --author="My name" --email=my@email.address That should create a file tree that you can get better acquainted with by reading L's fine documentation. For this example, the file you really need should now reside in C. This file probably starts with something like the following: package Perlbal::Plugin::ColorOfMagic; use warnings; use strict; You'll have to add a few functions to this file. These are described below. (note: upon creating this package, some boilerplate documentation will also be present on the file; you should revise it and even remove bits that don't feel right for your plugin) =head3 register C is called when the plugin is being added to a service. This is where you register your plugin's hooks, if required (see L for the list of existing hooks and further documentation on how they work). For the sake of our example (C, see above), what we want to do is register a hook that modifies the response headers; that means we want a C hook. Here's what you'd do: sub register { my ($class, $service) = @_; my $my_hook_code = sub { my Perlbal::ClientHTTPBase $cp = shift; if ( $cp->{req_headers}->header('X-Magic') ) { $cp->{res_headers}->header( 'X-Color', 'Octarine' ); } return 0; }; $service->register_hook('ColorOfMagic','modify_response_headers', $my_hook_code); } Inside C, we're calling C to register our C C hook. Its code, that will run "when we've set all the headers, and are about to serve a file" (see L), receives a L object (you can see what kind of object your hook will receive on L). We're checking to see if C is defined on the request and, if so, we're setting header C on the response to C. Notice that the hook ends with C. This is because returning a true value means that you want to cancel the connection to the backend and send the response to the client yourself. =head3 unregister C is called when the plugin is removed from a service. It's a standard good practice to unregister your plugin's hooks here, like so: sub unregister { my ($class, $service) = @_; $service->unregister_hooks('ColorOfMagic'); return 1; } You can also use C to unregister one single hook: $service->unregister_hook('ColorOfMagic', 'modify_response_headers'); =head3 load C is called when your plugin is loaded (or reloaded). This is where you should perform your plugin's initialization, which can go from setting up some variables to registering a management command (to register commands see the documentation for C further down this document). my $color; sub load { my $class = shift; $color = 'Octarine'; return 1; } C must always be defined, but if you really don't need it you can have it simply returning a true value: sub load { return 1; } =head3 unload C is called when your plugin is unloaded. This is where you should perform any clean up tasks. C must always be defined, but if you really don't need it you can have it simply returning a true value: sub unload { return 1; } Don't forget to call C if you have registered any (see the documentation for C further down this document and you'll see what we're talking about). =head3 register vs. load C is called when the plugin is loaded, while C is called whenever the plugin is set for a service. This means that you should use C for anything that is global, such as registering a global hook, and you should use C for things that are specific to a service, such as registering service hooks. =head3 dumpconfig C is not required. When managing Perlbal (see L) you can send a C command that will result in a configuration dump. Apart from the global configuration, each plugin that implements a C function will also have that function called. C should return an array of messages to be displayed. sub dumpconfig { my ($class, $service) = @_; my @messages; push @messages, "COLOROFMAGIC is $color"; return @messages; } Again, C is not required, so implement it only if it makes sense for your plugin. =head3 Helper functions =head4 add_tunable Adding a tunable will allow you to set its value within each plugin: LOAD MyPlugin CREATE SERVICE my_service SET my_new_parameter = 42 SET plugins = MyPlugin ENABLE my_service C can be used by plugins that want to add tunables so that the config file can have more options for service settings. sub load { Perlbal::Service::add_tunable( my_new_parameter => { check_role => '*', check_type => 'int', des => "description of my new parameter", default => 0, }, ); return 1; } C defines for which roles the value can be set (C, C, etc). A value of C<*> mean that the value can be set for any role. The acceptable values for C are C, C, C, C, C, C, C and C. An B error message will be displayed whenever you try to set a value that has an unknown C. C can also contain a code reference that will be used to validate the type. check_type => sub { my $self = shift; my $val = shift; my $emesg = shift; ... }, This code reference should return a true or false value. If returning false, the contents of C<$emesg> (which is passed as a reference to the function) will be used as the error message. Here's a better explanation of the acceptable values for C: =over 4 =item bool Boolean value. Must be defined and will be checked as a Perl value. =item directory_or_none The value needs to be defined and the content must be an existing directory (validated against perl's B<-d> switch). =item enum An array reference containing the acceptable values: check_type => [enum => ["yellow", "blue", "green"]], =item file A filename, validated against perl's B<-f> switch. =item file_or_none A filename, validated against perl's B<-f> switch, or the default value. =item int An integer value, validated against C. =item regexp Regular expression. The correct form of setting a regexp tunable is by setting it as an array reference containing the type (C), the regular expression and a message that can explain it: check_type => ["regexp", qr/^\d+\.\d+\.\d+\.\d+:\d+$/, "Expecting IP:port of form a.b.c.d:port."], =item size A size, validated against C. =back =head4 manage_command Perlbal catches unknown configuration commands and tries to match them against hooks in the form of C. Let's say that you want to set a management command C