Changeset 1308

Timestamp:

10/16/09 01:54:12 (6 weeks ago)

Author:

dormando

Message:

Upgrade perlbal mogdep to 1.73 and update MANIFEST

Location:

trunk/server

Files:

• MANIFEST (modified) (2 diffs)
• lib/mogdeps/Perlbal.pm (modified) (23 diffs)
• lib/mogdeps/Perlbal/AIO.pm (modified) (1 diff)
• lib/mogdeps/Perlbal/BackendHTTP.pm (modified) (13 diffs)
• lib/mogdeps/Perlbal/ClientHTTP.pm (modified) (8 diffs)
• lib/mogdeps/Perlbal/ClientHTTPBase.pm (modified) (19 diffs)
• lib/mogdeps/Perlbal/ClientManage.pm (modified) (3 diffs)
• lib/mogdeps/Perlbal/ClientProxy.pm (modified) (20 diffs)
• lib/mogdeps/Perlbal/CommandContext.pm (modified) (1 diff)
• lib/mogdeps/Perlbal/HTTPHeaders.pm (modified) (7 diffs)
• lib/mogdeps/Perlbal/ManageCommand.pm (modified) (1 diff)
• lib/mogdeps/Perlbal/Plugin/AccessControl.pm (modified) (6 diffs)
• lib/mogdeps/Perlbal/Plugin/AtomInject.pm (added)
• lib/mogdeps/Perlbal/Plugin/AtomStream.pm (added)
• lib/mogdeps/Perlbal/Plugin/Cgilike.pm (added)
• lib/mogdeps/Perlbal/Plugin/EchoService.pm (added)
• lib/mogdeps/Perlbal/Plugin/Highpri.pm (modified) (1 diff)
• lib/mogdeps/Perlbal/Plugin/Include.pm (added)
• lib/mogdeps/Perlbal/Plugin/LazyCDN.pm (added)
• lib/mogdeps/Perlbal/Plugin/MaxContentLength.pm (added)
• lib/mogdeps/Perlbal/Plugin/Palimg.pm (added)
• lib/mogdeps/Perlbal/Plugin/Redirect.pm (added)
• lib/mogdeps/Perlbal/Plugin/Stats.pm (modified) (3 diffs)
• lib/mogdeps/Perlbal/Plugin/Vhosts.pm (modified) (3 diffs)
• lib/mogdeps/Perlbal/Plugin/Vpaths.pm (added)
• lib/mogdeps/Perlbal/Pool.pm (modified) (2 diffs)
• lib/mogdeps/Perlbal/ReproxyManager.pm (modified) (1 diff)
• lib/mogdeps/Perlbal/Service.pm (modified) (22 diffs)
• lib/mogdeps/Perlbal/Socket.pm (modified) (8 diffs)
• lib/mogdeps/Perlbal/SocketSSL.pm (added)
• lib/mogdeps/Perlbal/TCPListener.pm (modified) (6 diffs)
• lib/mogdeps/Perlbal/Test.pm (modified) (11 diffs)
• lib/mogdeps/Perlbal/Test/WebClient.pm (modified) (2 diffs)
• lib/mogdeps/Perlbal/UploadListener.pm (modified) (2 diffs)
• lib/mogdeps/Perlbal/Util.pm (modified) (1 diff)

trunk/server/MANIFEST

@@ -39 +39 @@
 lib/mogdeps/Perlbal/Plugin/Stats.pm
 lib/mogdeps/Perlbal/Plugin/Vhosts.pm
+lib/mogdeps/Perlbal/Plugin/AtomInject.pm
+lib/mogdeps/Perlbal/Plugin/AtomStream.pm
+lib/mogdeps/Perlbal/Plugin/Cgilike.pm
+lib/mogdeps/Perlbal/Plugin/EchoService.pm
+lib/mogdeps/Perlbal/Plugin/Include.pm
+lib/mogdeps/Perlbal/Plugin/LazyCDN.pm
+lib/mogdeps/Perlbal/Plugin/MaxContentLength.pm
+lib/mogdeps/Perlbal/Plugin/Palimg.pm
+lib/mogdeps/Perlbal/Plugin/Redirect.pm
+lib/mogdeps/Perlbal/Plugin/Vpaths.pm
 lib/mogdeps/Perlbal/Pool.pm
 lib/mogdeps/Perlbal/ReproxyManager.pm
@@ -49 +59 @@
 lib/mogdeps/Perlbal/UploadListener.pm
 lib/mogdeps/Perlbal/Util.pm
+lib/mogdeps/Perlbal/SocketSSL.pm
 lib/mogdeps/Sys/Syscall.pm
 lib/MogileFS/Class.pm

trunk/server/lib/mogdeps/Perlbal.pm

@@ -1 +1 @@
 #!/usr/bin/perl
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -15 +15 @@
 =head1 COPYRIGHT AND LICENSE
 
-Copyright 2004, Danga Interactice, Inc.
-Copyright 2005-2006, Six Apart, Ltd.
+Copyright 2004, Danga Interactive, Inc.
+Copyright 2005-2007, Six Apart, Ltd.
 
 You can use and redistribute Perlbal under the same terms as Perl itself.
@@ -26 +26 @@
 BEGIN {
     # keep track of anonymous subs' origins:
-    $^P = 0x200;
+    $^P |= 0x200;
 }
 
@@ -34 +34 @@
 
 use vars qw($VERSION);
-$VERSION = '1.59';
+$VERSION = '1.73';
 
 use constant DEBUG => $ENV{PERLBAL_DEBUG} || 0;
@@ -54 +54 @@
 # 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;
@@ -90 +93 @@
 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
@@ -95 +99 @@
 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
 
@@ -186 +194 @@
     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);
 }
 
@@ -241 +264 @@
     # expand variables
     $cmd =~ s/\$\{(.+?)\}/_expand_config_var($1)/eg;
+    $cmd =~ s/\$(\w+)/$ENV{$1}/g;
 
     $out ||= sub {};
@@ -381 +405 @@
 
 sub MANAGE_shutdown {
-    my $mc = shift->parse(qr/^shutdown( graceful)?$/);
+    my $mc = shift->parse(qr/^shutdown(\s?graceful)?\s?(\d+)?$/);
 
     # immediate shutdown
@@ -415 +439 @@
     });
 
+    # 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 <ext> <mime>");
+        }
+
+        $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 <ext>, add <ext> <mime>");
+    }
 }
 
@@ -632 +688 @@
         foreach (sort { $a <=> $b } keys %$sf) {
             my $sock = $sf->{$_};
-            my $age = $now - $sock->{create_time};
+            my $age;
+            eval {
+                $age = $now - $sock->{create_time};
+            };
+            $age ||= 0;
             $mc->out(sprintf("%5d %5ds %s", $_, $age, $sock->as_string));
         }
@@ -708 +768 @@
     my %states; # { "Class" => { "State" => int count; } }
     foreach my $sock (values %$sf) {
+        next unless $sock->can('state');
         my $state = $sock->state;
         next unless defined $state;
@@ -735 +796 @@
         next unless $svc->{role} eq 'reverse_proxy';
 
-        my ($age, $count) = (0, scalar(@{$svc->{waiting_clients}}));
-        my Perlbal::ClientProxy $oldest = $svc->{waiting_clients}->[0];
-        $age = $now - $oldest->{last_request_time} if defined $oldest;
-        $mc->out("$svc->{name}-normal.age $age");
-        $mc->out("$svc->{name}-normal.count $count");
-
-        ($age, $count) = (0, scalar(@{$svc->{waiting_clients_highpri}}));
-        $oldest = $svc->{waiting_clients_highpri}->[0];
-        $age = $now - $oldest->{last_request_time} if defined $oldest;
-        $mc->out("$svc->{name}-highpri.age $age");
-        $mc->out("$svc->{name}-highpri.count $count");
+        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;
@@ -767 +831 @@
     my $mc = shift->parse(qr/^leaks(?:\s+(.+))?$/);
     return $mc->err("command disabled without \$ENV{PERLBAL_DEBUG} set")
-        unless $ENV{PERBAL_DEBUG};
+        unless $ENV{PERLBAL_DEBUG};
 
     my $what = $mc->arg(1);
@@ -891 +955 @@
     }
 
+    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
 }
 
@@ -908 +1028 @@
         return $mc->err("service '$name' already exists") if $service{$name};
         return $mc->err("pool '$name' already exists") if $pool{$name};
-        $service{$name} = Perlbal::Service->new($name);
+        Perlbal->create_service($name);
         $mc->{ctx}{last_created} = $name;
         return $mc->ok;
@@ -1090 +1210 @@
 sub load_config {
     my ($file, $writer) = @_;
-    open (F, $file) or die "Error opening config file ($file): $!\n";
+    open (my $fh, $file) or die "Error opening config file ($file): $!\n";
     my $ctx = Perlbal::CommandContext->new;
     $ctx->verbose(0);
-    while (my $line = <F>) {
-        $line =~ s/\$(\w+)/$ENV{$1}/g;
+    while (my $line = <$fh>) {
         return 0 unless run_manage_command($line, $writer, $ctx);
     }
-    close(F);
+    close($fh);
     return 1;
 }
@@ -1118 +1237 @@
         unless $sess_id = POSIX::setsid();
 
-    ## Prevent possibility of acquiring a controling terminal
+    ## Prevent possibility of acquiring a controlling terminal
     $SIG{'HUP'} = 'IGNORE';
     if ($pid = fork) { exit 0; }
@@ -1139 +1258 @@
 }
 
+# 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');
-
-    # 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);
-    }
-
+    my $pidfile_written = 0;
+    $pidfile_written = _write_pidfile( $pidfile ) if $pidfile;
+
+    Perlbal::initialize();
 
     Danga::Socket->SetLoopTimeout(1000);
@@ -1163 +1304 @@
     });
 
-    run_global_hook("pre_event_loop");
-
     # begin the overall loop to try to capture if Perlbal dies at some point
     # so we can have a log of it
@@ -1179 +1318 @@
         $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;
 
@@ -1189 +1335 @@
     if ($foreground) {
         # syslog acts like printf so we have to use printf and append a \n
-        shift; # ignore the first parameter (info, warn, critical, etc)
+        shift; # ignore the first parameter (info, warn, crit, etc)
         printf(shift(@_) . "\n", @_);
     } else {
         # just pass the parameters to syslog
-        Sys::Syslog::syslog(@_) if $Perlbal::SYSLOG_AVAILABLE;
-    }
-}
+        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:

trunk/server/lib/mogdeps/Perlbal/AIO.pm

@@ -1 +1 @@
 # AIO abstraction layer
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 
 package Perlbal::AIO;

trunk/server/lib/mogdeps/Perlbal/BackendHTTP.pm

@@ -2 +2 @@
 # HTTP connection to backend node
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -39 +39 @@
             'generation', # int; counts what generation we were spawned in
             'buffered_upload_mode', # bool; if on, we're doing a buffered upload transmit
+
+            'scratch' # for plugins
             );
 use Socket qw(PF_INET IPPROTO_TCP SOCK_STREAM SOL_SOCKET SO_ERROR
@@ -62 +64 @@
 #       reportto => object obeying reportto interface
 sub new {
-    my ($class, $svc, $ip, $port, $opts) = @_;
+    my Perlbal::BackendHTTP $self = shift;
+    my ($svc, $ip, $port, $opts) = @_;
     $opts ||= {};
 
@@ -72 +75 @@
         return undef;
     }
+    my $inet_aton = Socket::inet_aton($ip);
+    unless ($inet_aton) {
+        Perlbal::log('crit', "inet_aton failed creating socket for $ip");
+        return undef;
+    }
 
     IO::Handle::blocking($sock, 0);
-    connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($ip));
-
-    my $self = fields::new($class);
+    connect $sock, Socket::sockaddr_in($port, $inet_aton);
+
+    $self = fields::new($self) unless ref $self;
     $self->SUPER::new($sock);
 
@@ -105 +113 @@
     $self->init;
 
-    bless $self, ref $class || $class;
     $self->watch_write(1);
     return $self;
@@ -167 +174 @@
 
     $self->init;
-    bless $self, ref $class || $class;
     $self->watch_write(1);
     return $self;
@@ -265 +271 @@
     if ($svc->trusted_ip($client_ip)) {
         # yes, we trust our upstream, so just append our client's IP
-        # to the existing list of forwarded IPs
-        my @ips = split /,\s*/, ($hds->header("X-Forwarded-For") || '');
-        $hds->header("X-Forwarded-For", join ", ", @ips, $client_ip);
+        # to the existing list of forwarded IPs, if we're a blind proxy
+        # then don't append our IP to the end of the list.
+        unless ($svc->{blind_proxy}) {
+            my @ips = split /,\s*/, ($hds->header("X-Forwarded-For") || '');
+            $hds->header("X-Forwarded-For", join ", ", @ips, $client_ip);
+        }
     } else {
         # no, don't trust upstream (untrusted client), so remove all their
@@ -343 +352 @@
             !$self->{has_attention} && !defined $NoVerify{$self->{ipport}}) {
 
+            return if $self->{service}->run_hook('backend_write_verify', $self);
+
             # the backend should be able to answer this incredibly quickly.
-            $self->write("OPTIONS * HTTP/1.0\r\nConnection: keep-alive\r\n\r\n");
+            $self->write("OPTIONS " . $self->{service}->{verify_backend_path} . " HTTP/1.0\r\nConnection: keep-alive\r\n\r\n");
             $self->watch_read(1);
             $self->{waiting_options} = 1;
@@ -368 +379 @@
 }
 
+sub verify_success {
+    my Perlbal::BackendHTTP $self = shift;
+    $self->{waiting_options} = 0;
+    $self->{has_attention} = 1;
+    $NodeStats{$self->{ipport}}->{verifies}++;
+    $self->next_request(1); # initial
+    return;
+}
+
 sub verify_failure {
     my Perlbal::BackendHTTP $self = shift;
@@ -378 +398 @@
 sub event_read_waiting_options { # : void
     my Perlbal::BackendHTTP $self = shift;
+
+    if (defined $self->{service}) {
+        return if $self->{service}->run_hook('backend_readable_verify', $self);
+    }
+
     if ($self->{content_length_remain}) {
         # the HTTP/1.1 spec says OPTIONS responses can have content-lengths,
@@ -394 +419 @@
     # if present:
     if ($self->{res_headers} && ! $self->{content_length_remain}) {
-        # other setup to mark being done with options checking
-        $self->{waiting_options} = 0;
-        $self->{has_attention} = 1;
-        $NodeStats{$self->{ipport}}->{verifies}++;
-        $self->next_request(1); # initial
+        $self->verify_success;
     }
     return;
@@ -454 +475 @@
     if ((my $rep = $hd->header('X-REPROXY-FILE')) && $self->may_reproxy) {
         # make the client begin the async IO while we move on
+        $self->next_request;
         $client->start_reproxy_file($rep, $hd);
+        return;
+    } elsif ((my $urls = $hd->header('X-REPROXY-URL')) && $self->may_reproxy) {
         $self->next_request;
-        return;
-    } elsif ((my $urls = $hd->header('X-REPROXY-URL')) && $self->may_reproxy) {
         $self->{service}->add_to_reproxy_url_cache($rqhd, $hd)
             if $reproxy_cache_for;
-        $client->start_reproxy_uri($self->{res_headers}, $urls);
+        $client->start_reproxy_uri($hd, $urls);
+        return;
+    } elsif ((my $svcname = $hd->header('X-REPROXY-SERVICE')) && $self->may_reproxy) {
         $self->next_request;
-        return;
-    } elsif ((my $svcname = $hd->header('X-REPROXY-SERVICE')) && $self->may_reproxy) {
         $self->{client} = undef;
-        $client->start_reproxy_service($self->{res_headers}, $svcname);
-        $self->next_request;
+        $client->start_reproxy_service($hd, $svcname);
         return;
     } elsif ($res_code == 500 &&
@@ -500 +521 @@
         # also update the response code, in case of 206 partial content
         my $rescode = $hd->response_code;
-        $thd->code($rescode) if $rescode == 206 || $rescode == 416;
+        if ($rescode == 206 || $rescode == 416) {
+            $thd->code($rescode);
+            $thd->header('Accept-Ranges', $hd->header('Accept-Ranges')) if $hd->header('Accept-Ranges');
+            $thd->header('Content-Range', $hd->header('Content-Range')) if $hd->header('Content-Range');
+        } 
         $thd->code(200) if $thd->response_code == 204;  # upgrade HTTP No Content (204) to 200 OK.
     }

trunk/server/lib/mogdeps/Perlbal/ClientHTTP.pm

@@ -3 +3 @@
 #  most functionality is implemented in the base class.
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -13 +13 @@
 
 use base "Perlbal::ClientHTTPBase";
+use Perlbal::Util;
 
 use fields ('put_in_progress', # 1 when we're currently waiting for an async job to return
@@ -47 +48 @@
     my $class = shift;
     my Perlbal::ClientHTTPBase $cb = shift;    # base object
-    bless $cb, $class;
+    Perlbal::Util::rebless($cb, $class);
     $cb->init;
 
@@ -102 +103 @@
     my $hd = $self->{req_headers};
 
+    $self->check_req_headers;
+
     # fully formed request received
     $self->{requests}++;
@@ -143 +146 @@
     # bigger than any specified max put size
     return $self->send_response(400, "Content-length of $clen is invalid.")
-        if !$clen ||
+        if ! defined($clen) ||
+        $clen < 0 ||
         ($self->{service}->{max_put_size} &&
          $clen > $self->{service}->{max_put_size});
 
-    # if we have some data already from a header over-read, note it
-    if (defined $self->{read_ahead} && $self->{read_ahead} > 0) {
+    # if we are supposed to read data and have some data already from a header over-read, note it
+    if ($clen && defined $self->{read_ahead} && $self->{read_ahead} > 0) {
         $self->{content_length_remain} -= $self->{read_ahead};
     }
@@ -225 +229 @@
 
     my $disk_path = $self->{service}->{docroot} . '/' . $path;
-    $self->start_put_open($disk_path, $filename);
 
     $self->{chunked_upload_state} = Perlbal::ChunkedUploadState->new(%{{
@@ -265 +268 @@
         },
     }});
+
+    $self->start_put_open($disk_path, $filename);
 
     return 1;
@@ -393 +398 @@
         $self->{put_fh_filename} = "$path/$file";
 
+        # We just opened the file, haven't read_ahead any bytes, are expecting 0 bytes for read and we're
+        # not in chunked mode, so close the file immediately, we're done.
+        unless ($self->{read_ahead} || $self->{content_length_remain} || $self->{chunked_upload_state}) {
+            # FIXME this should be done through AIO
+            $self->put_close;
+            return;
+        }
+
         $self->put_writeout;
     });

trunk/server/lib/mogdeps/Perlbal/ClientHTTPBase.pm

@@ -8 +8 @@
 # for another request from the user
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 
 package Perlbal::ClientHTTPBase;
@@ -40 +40 @@
 
 use Fcntl ':mode';
-use Errno qw( EPIPE ECONNRESET );
+use Errno qw(EPIPE ECONNRESET);
 use POSIX ();
 
-# ghetto hard-coding.  should let siteadmin define or something.
-# maybe console/config command:  AddMime <ext> <mime-type>  (apache-style?)
+# hard-code defaults can be changed with MIME management command
 our $MimeType = {qw(
                     css  text/css
@@ -55 +54 @@
                     mp3  audio/mpeg
                     mpg  video/mpeg
+                    pdf  application/pdf
                     png  image/png
                     tif   image/tiff
@@ -65 +65 @@
 # ClientHTTPBase
 sub new {
-    my ($class, $service, $sock, $selector_svc) = @_;
-
-    my $self = $class;
-    $self = fields::new($class) unless ref $self;
+
+    my Perlbal::ClientHTTPBase $self = shift;
+    my ($service, $sock, $selector_svc) = @_;
+    $self = fields::new($self) unless ref $self;
     $self->SUPER::new($sock);       # init base fields
 
@@ -80 +80 @@
     $self->state('reading_headers');
 
-    bless $self, ref $class || $class;
     $self->watch_read(1);
     return $self;
@@ -125 +124 @@
     if ($do_keepalive) {
         print "  doing keep-alive to client\n" if Perlbal::DEBUG >= 3;
-        my $timeout = $self->max_idle_time;
+        my $timeout = $self->{service}->{persist_client_timeout};
         $reshd->header('Connection', 'keep-alive');
         $reshd->header('Keep-Alive', $timeout ? "timeout=$timeout, max=100" : undef);
@@ -137 +136 @@
         $reshd->header('Keep-Alive', undef);
     }
+}
+
+# overridden here from Perlbal::Socket to use the service value
+sub max_idle_time {
+    return $_[0]->{service}->{persist_client_timeout};
+}
+
+# Called when this client is entering a persist_wait state, but before we are returned to base.
+sub persist_wait {
+    
 }
 
@@ -189 +198 @@
     $self->state('persist_wait');
 
+    $self->persist_wait;
+
     if (my $selector_svc = $self->{selector_svc}) {
-        $selector_svc->return_to_base($self);
+        if (! $selector_svc->run_hook('return_to_base', $self)){
+            $selector_svc->return_to_base($self);
+        }
     }
 
@@ -210 +223 @@
         $self->{reproxy_file_offset} = 0;
         $self->{reproxy_file_size} = $size;
-        # 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;
+
+        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;
+        }
     }
 
@@ -222 +265 @@
 sub event_read {
     my Perlbal::ClientHTTPBase $self = shift;
+
+    $self->{alive_time} = $Perlbal::tick_time;
 
     # see if we have headers?
@@ -236 +281 @@
     # 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
-    # renable reads.
+    # re-enable reads.
     $self->watch_read(0);
 
@@ -257 +302 @@
 }
 
+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)
@@ -264 +322 @@
     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->{service}->{listener}->{sslopts}) { # 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;
-
-    $self->watch_write(0);
 
     my $postread = sub {
@@ -289 +382 @@
 
         if ($sent >= $remain) {
-            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;
-            }
+            $self->reproxy_file_done;
         } else {
             $self->watch_write(1);
@@ -533 +616 @@
     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
@@ -585 +669 @@
     }
 
-    # What is -f _ doing here? don't we detect the existance of all files above in the loop?
+    # 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 _;
 
@@ -651 +735 @@
     };
     $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;
 }
 
@@ -765 +865 @@
 }
 
-# FIXME: let this be configurable?
-sub max_idle_time { 30; }
-
 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;
@@ -776 +881 @@
     my $ret = $self->SUPER::as_string;
     my $name = $self->{sock} ? getsockname($self->{sock}) : undef;
-    my $lport = $name ? (Socket::sockaddr_in($name))[0] : 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}";

trunk/server/lib/mogdeps/Perlbal/ClientManage.pm

@@ -17 +17 @@
 # ClientManage
 sub new {
-    my ($class, $service, $sock) = @_;
-    my $self = $class->SUPER::new($sock);
+    my Perlbal::ClientManage $self = shift;
+    my ($service, $sock) = @_;
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new($sock);
     $self->{service} = $service;
     $self->{buf} = "";   # what we've read so far, not forming a complete line
@@ -25 +27 @@
     $self->{ctx}->verbose(1);
 
-    bless $self, ref $class || $class;
     $self->watch_read(1);
     return $self;
@@ -112 +113 @@
             my Perlbal::Service $svc = Perlbal->service($sname);
             next unless $svc;
-            $body .= "<li><a href='/service?$sname'>$sname</a> - $svc->{role} ($svc->{listen})</li>\n";
+            my $listen = $svc->{listen} ? " ($svc->{listen})" : "";
+            $body .= "<li><a href='/service?$sname'>$sname</a> - $svc->{role}$listen</li>\n";
         }
         $body .= "</ul></li>";

trunk/server/lib/mogdeps/Perlbal/ClientProxy.pm

@@ -2 +2 @@
 # HTTP Connection from a reverse proxy client
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 package Perlbal::ClientProxy;
@@ -12 +12 @@
 
 use Perlbal::ChunkedUploadState;
+use Perlbal::Util;
 
 use fields (
@@ -60 +61 @@
 # ClientProxy
 sub new {
-    my ($class, $service, $sock) = @_;
-
-    my $self = $class;
-    $self = fields::new($class) unless ref $self;
-    $self->SUPER::new($service, $sock);       # init base fields
+    my Perlbal::ClientProxy $self = shift;
+    my ($service, $sock) = @_;
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new($service,  $sock );
 
     Perlbal::objctor($self);
-    bless $self, ref $class || $class;
 
     $self->init;
@@ -77 +76 @@
     my $class = shift;
     my Perlbal::ClientHTTPBase $cb = shift;
-    bless $cb, $class;
+    Perlbal::Util::rebless($cb, $class);
     $cb->init;
     $cb->watch_read(1);
@@ -232 +231 @@
         $extra_hdr .= "Range: $range\r\n";
     }
-
-    my $host = $datref->[0];
-    $extra_hdr .= "Host: $host\r\n" if $host;
+    if (my $host = $self->{req_headers}->header("Host")) {
+        $extra_hdr .= "Host: $host\r\n";
+    }
 
     my $req_method = $self->{req_headers}->request_method eq 'HEAD' ? 'HEAD' : 'GET';
@@ -318 +317 @@
 
         # if the thing we're reproxying is indeed a file, advertise that
-        # we support byteranges on it
+        # we support byte ranges on it
         if (-f _) {
             $hd->header("Accept-Ranges", "bytes");
@@ -428 +427 @@
     print "ClientProxy::backend_finished\n" if Perlbal::DEBUG >= 3;
 
-    # mark ourselves as having responded (presumeably if we're here,
+    # mark ourselves as having responded (presumably if we're here,
     # the backend has responded already)
     $self->{responded} = 1;
@@ -440 +439 @@
 
     # if we get here (and we do, rarely, in practice) then that means
-    # the backend read was empty/disconected (or otherwise messed up),
+    # the backend read was empty/disconnected (or otherwise messed up),
     # and the only thing we can really do is close the client down.
     $self->close("backend_finished_while_unread_data");
+}
+
+# Called when this client is entering a persist_wait state, but before we are returned to base.
+sub persist_wait {
+    my Perlbal::ClientProxy $self = $_[0];
+    # We're in keepalive, and just completed a proxy request
+    $self->{service}->run_hooks('end_proxy_request', $self);
 }
 
@@ -506 +512 @@
     my $reason = shift;
 
+    warn sprintf(
+                    "Perlbal::ClientProxy closed %s%s.\n",
+                    ( $self->{closed} ? "again " : "" ),
+                    (defined $reason ? "saying '$reason'" : "for an unknown reason")
+    ) if Perlbal::DEBUG >= 2;
+
     # don't close twice
     return if $self->{closed};
@@ -544 +556 @@
     print "ClientProxy::event_write\n" if Perlbal::DEBUG >= 3;
 
-    $self->SUPER::event_write;
-
     # obviously if we're writing the backend has processed our request
     # and we are responding/have responded to the user, so mark it so
     $self->{responded} = 1;
+
+    # will eventually, finally reset the whole object on completion
+    $self->SUPER::event_write;
 
     # trigger our backend to keep reading, if it's still connected
@@ -731 +744 @@
     my $req_hd = $self->{req_headers};
 
+    unless ($req_hd) {
+        $self->close("handle_request without headers");
+        return;
+    }
+
+    $self->check_req_headers;
+
     my $svc = $self->{service};
     # give plugins a chance to force us to bail
@@ -742 +762 @@
         # subtract out read_size, which is the amount of data that was
         # extra in the packet with the header that's part of the body.
-        $self->{request_body_length} =
+        my $length = $self->{request_body_length} =
             $self->{content_length_remain} =
             $req_hd->content_length;
+
+        if (defined $length && $length < 0) {
+            $self->_simple_response(400, "Invalid request: Content-Length < 0");
+            $self->close("negative_content_length");
+            return;
+        }
+
         $self->{unread_data_waiting} = 1 if $self->{content_length_remain};
     }
@@ -1003 +1030 @@
     my $clen = $self->{req_headers}->content_length;
     if ($clen != $self->{buoutpos}) {
-        Perlbal::log('critical', "Content length of $clen declared but $self->{buoutpos} bytes written to disk");
+        Perlbal::log('crit', "Content length of $clen declared but $self->{buoutpos} bytes written to disk");
         return $self->_simple_response(500);
     }
@@ -1009 +1036 @@
     # reset our position so we start reading from the right spot
     $self->{buoutpos} = 0;
-    sysseek($self->{bufh}, 0, 0);
+    sysseek($self->{bufh}, 0, 0) if ($self->{bufh}); # But only if it exists at all
 
     # notify that we want the backend so we get the ball rolling
@@ -1023 +1050 @@
     my $clen = $self->{request_body_length};
 
-    my $sent = Perlbal::Socket::sendfile($be->{fd}, fileno($self->{bufh}), $clen - $self->{buoutpos});
-    if ($sent < 0) {
-        return $self->close("epipe") if $! == EPIPE;
-        return $self->close("connreset") if $! == ECONNRESET;
-        print STDERR "Error w/ sendfile: $!\n";
-        return $self->close('sendfile_error');
-    }
-    $self->{buoutpos} += $sent;
+    if ($self->{buoutpos} < $clen) {
+        my $sent = Perlbal::Socket::sendfile($be->{fd}, fileno($self->{bufh}), $clen - $self->{buoutpos});
+        if ($sent < 0) {
+            return $self->close("epipe") if $! == EPIPE;
+            return $self->close("connreset") if $! == ECONNRESET;
+            print STDERR "Error w/ sendfile: $!\n";
+            return $self->close('sendfile_error');
+        }
+        $self->{buoutpos} += $sent;
+    }
 
     # if we're done, purge the file and move on
@@ -1062 +1091 @@
             # throw errors back to the user
             if (! $self->{bufh}) {
-                Perlbal::log('critical', "Failure to open $fn for buffered upload output");
+                Perlbal::log('crit', "Failure to open $fn for buffered upload output");
                 return $self->_simple_response(500);
             }
@@ -1097 +1126 @@
 
         # check for error
-        unless ($bytes) {
-            Perlbal::log('critical', "Error writing buffered upload: $!.  Tried to do $len bytes at $self->{buoutpos}.");
+        unless ($bytes > 0) {
+            Perlbal::log('crit', "Error writing buffered upload: $!.  Tried to do $len bytes at $self->{buoutpos}.");
             return $self->_simple_response(500);
         }
@@ -1106 +1135 @@
 
         # now check if we wrote less than we had in this chunk of buffer.  if that's
-        # the case then we need to reenqueue the part of the chunk that wasn't
+        # the case then we need to re-enqueue the part of the chunk that wasn't
         # written out and update as appropriate.
         if ($bytes < $len) {
@@ -1144 +1173 @@
     my Perlbal::ClientProxy $self = shift;
 
+    # Main reason for failure below is a 0-length chunked upload, where the file is never created.
+    return unless $self->{bufh};
+
     # FIXME: it's reported that sometimes the two now-in-eval blocks
     # fail, hence the eval blocks and warnings.  the FIXME is to
@@ -1157 +1189 @@
 
     eval {
-        # now asyncronously unlink the file
+        # now asynchronously unlink the file
         Perlbal::AIO::aio_unlink($self->{bufilename}, sub {
             if ($!) {

trunk/server/lib/mogdeps/Perlbal/CommandContext.pm

@@ -2 +2 @@
 # can be less verbose when in config files
 #
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 

trunk/server/lib/mogdeps/Perlbal/HTTPHeaders.pm

@@ -2 +2 @@
 # HTTP header class (both request and response)
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -10 +10 @@
 use warnings;
 no  warnings qw(deprecated);
+
+use Perlbal;
 
 use fields (
@@ -30 +32 @@
     204 => 'No Content',
     206 => 'Partial Content',
+    301 => 'Permanent Redirect',
+    302 => 'Found',
     304 => 'Not Modified',
     400 => 'Bad request',
@@ -104 +108 @@
         # check for valid response line
         return fail("Bogus response line") unless
-            $self->{responseLine} =~ m!^HTTP\/(\d+)\.(\d+)\s+(\d+)\s+(.+)$!;
+            $self->{responseLine} =~ m!^HTTP\/(\d+)\.(\d+)\s+(\d+)\s+(.*)$!;
 
         my ($ver_ma, $ver_mi, $code) = ($1, $2, $3);
@@ -223 +227 @@
 }
 
+sub set_request_uri {
+    my Perlbal::HTTPHeaders $self = shift;
+    return unless $self->{requestLine};
+
+    my $uri = shift;
+
+    return unless defined $uri and length $uri;
+
+    my $ver = $self->{ver};
+
+    if ($ver == 0.9) {
+        $self->{requestLine} = sprintf("%s %s", $self->{method}, $uri);
+    } else {
+        $self->{requestLine} = sprintf("%s %s HTTP/%s", $self->{method}, $uri, $ver);
+    }
+
+    return $self->{uri} = $uri;
+}
+
 sub version_number {
     my Perlbal::HTTPHeaders $self = $_[0];
@@ -243 +266 @@
 
     return $self->{headers}{$key} = shift;
+}
+
+sub headers_list {
+    my Perlbal::HTTPHeaders $self = shift;
+    return [$self->{headers} ? keys %{ $self->{headers} } : ()];
 }
 
@@ -407 +435 @@
 # returns (status, range_start, range_end) when given a size
 # status = 200 - invalid or non-existent range header.  serve normally.
-# status = 206 - parsable range is good.  serve partial content.
+# status = 206 - parseable range is good.  serve partial content.
 # status = 416 - Range is unsatisfiable
 sub range {

trunk/server/lib/mogdeps/Perlbal/ManageCommand.pm

@@ -2 +2 @@
 # to a command should be done through this instance (out, err, ok, etc)
 #
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 

trunk/server/lib/mogdeps/Perlbal/Plugin/AccessControl.pm

@@ -35 +35 @@
                               (?:\s+(\S+))?                  # optional arg2
                               $/x,
-                              "usage: ACCESS [<service>] <cmd> <arg1> [<arg2>]");
+                              "usage: ACCESS <cmd> <arg1> [<arg2>]");
         my ($cmd, $arg1, $arg2) = $mc->args;
 
@@ -87 +87 @@
 sub unload {
     my $class = shift;
-    Perlbal::unregister_global_hook('manage_command.vhost');
+    Perlbal::unregister_global_hook('manage_command.access');
     return 1;
 }
@@ -94 +94 @@
 sub register {
     my ($class, $svc) = @_;
+
+    my $use_observed_ip;
 
     $svc->register_hook('AccessControl', 'start_http_request', sub {
@@ -126 +128 @@
             my $rule = shift;
             if ($rule->[1] eq "ip") {
-                my $peer_ip = $client->peer_ip_string;
+                my $peer_ip;
+                $peer_ip = $client->observed_ip_string if $use_observed_ip;
+                $peer_ip ||= $client->peer_ip_string;
+
                 return $peer_ip eq $rule->[2];
             }
 
             if ($rule->[1] eq "netmask") {
-                my $peer_ip = $client->peer_ip_string;
+                my $peer_ip;
+                $peer_ip = $client->observed_ip_string if $use_observed_ip;
+                $peer_ip ||= $client->peer_ip_string;
+
                 return eval { $rule->[2]->match($peer_ip); };
             }
-
         };
 
@@ -148 +155 @@
     });
 
+    # Allow AccessControl users to specify that they would like to use the observed IP as
+    # opposed to the real IP for ACL checking.
+    $svc->register_setter('AccessControl', 'use_observed_ip', sub {
+        my ($out, $what, $val) = @_;
+        return 0 unless $what;
+
+        $use_observed_ip = $val;
+
+        $out->("OK") if $out;
+
+        return 1;
+    });
+
+
     return 1;
 }
@@ -157 +178 @@
 }
 
+sub dumpconfig {
+    my ($class, $svc) = @_;
+
+    my @return;
+
+    my $cfg = $svc->{extra_config}->{_access} ||= {};
+    my $rules = $cfg->{rules} || [];
+
+    foreach my $rule (@$rules) {
+        my $action = uc $rule->[0];
+        my $type   = uc $rule->[1];
+        my $value  = $rule->[2];
+        push @return, "ACCESS $action $type $value";
+    }
+
+    my $default_action = $cfg->{deny_default} ? "DENY" : "ALLOW";
+    push @return, "ACCESS POLICY $default_action";
+
+    return @return;
+}
+
 1;

trunk/server/lib/mogdeps/Perlbal/Plugin/Highpri.pm

@@ -39 +39 @@
         my $temp;
         unless ($val eq 'undef' || $val eq 'none' || $val eq 'null') {
-            # verify this regex works?  do it in an eval because qr will die
+            # verify this regexp works?  do it in an eval because qr will die
             # if we give it something invalid
             eval {

trunk/server/lib/mogdeps/Perlbal/Plugin/Stats.pm

@@ -28 +28 @@
 
     # simple events we count are done here.  when the hook on the left side is called,
-    # we simply increment the count of the stat ont he right side.
+    # we simply increment the count of the stat on the right side.
     my %simple = qw(
         start_send_file         files_sent
@@ -44 +44 @@
     $svc->register_hook('Stats', 'backend_client_assigned', sub {
         my Perlbal::BackendHTTP $be = shift;
-        $sobj->{pending}->{"$be->{client}"} = [ gettimeofday() ];
-        ($be->{client}->{high_priority} ? $sobj->{proxy_requests_highpri} : $sobj->{proxy_requests})++;
+        my Perlbal::ClientProxy $cp = $be->{client};
+        $sobj->{pending}->{"$cp"} = [ gettimeofday() ];
+        ($cp->{high_priority} ? $sobj->{proxy_requests_highpri} : $sobj->{proxy_requests})++;
         return 0;
     });
@@ -51 +52 @@
         my Perlbal::BackendHTTP $be = shift;
         my Perlbal::ClientProxy $obj = $be->{client};
-        my $ot = $sobj->{pending}->{"$obj"};
+        my $ot = delete $sobj->{pending}->{"$obj"};
         return 0 unless defined $ot;
 

trunk/server/lib/mogdeps/Perlbal/Plugin/Vhosts.pm

@@ -4 +4 @@
 
 # things to test:
-#   one persistent connection, first to a docs plugin, then to web proxy... see if it returns us to our base class after end of reuqest
+#   one persistent connection, first to a docs plugin, then to web proxy... see if it returns us to our base class after end of request
 #   PUTing a large file to a selector, seeing if it is put correctly to the PUT-enabled web_server proxy
-#   obvious cases:  non-existant domains, default domains (*), proper matching (foo.brad.lj before *.brad.lj)
+#   obvious cases:  non-existent domains, default domains (*), proper matching (foo.brad.lj before *.brad.lj)
 #
 
@@ -76 +76 @@
 }
 
+sub dumpconfig {
+    my ($class, $svc) = @_;
+
+    my $vhosts = $svc->{extra_config}->{_vhosts};
+
+    return unless $vhosts;
+
+    my @return;
+
+    while (my ($vhost, $target) = each %$vhosts) {
+        push @return, "VHOST $vhost = $target";
+    }
+
+    return @return;
+}
+
 # call back from Service via ClientHTTPBase's event_read calling service->select_new_service(Perlbal::ClientHTTPBase)
 sub vhost_selector {
@@ -84 +100 @@
 
     my $vhost = $req->header("Host");
+
+    # Browsers and the Apache API considers 'www.example.com.' == 'www.example.com'
+    $vhost and $vhost =~ s/\.$//;
+
     my $uri = $req->request_uri;
     my $maps = $cb->{service}{extra_config}{_vhosts} ||= {};

trunk/server/lib/mogdeps/Perlbal/Pool.pm

@@ -3 +3 @@
 ######################################################################
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -95 +95 @@
 }
 
+sub dumpconfig {
+    my Perlbal::Pool $self = shift;
+    my $name = $self->{name};
+
+    my @return;
+
+    if (my $nodefile = $self->{'nodefile'}) {
+        push @return, "SET nodefile = $nodefile";
+    } else {
+        foreach my $node (@{$self->{nodes}}) {
+            my ($ip, $port) = @$node;
+            push @return, "POOL ADD $name $ip:$port";
+        }
+    }
+    return @return;
+}
+
 # returns string of balance method
 sub balance_method {

trunk/server/lib/mogdeps/Perlbal/ReproxyManager.pm

@@ -1 +1 @@
 # HTTP connection to non-pool backend nodes (probably fast event-based webservers)
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 

trunk/server/lib/mogdeps/Perlbal/Service.pm

@@ -3 +3 @@
 ######################################################################
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 #
 
@@ -14 +14 @@
 use Perlbal::BackendHTTP;
 use Perlbal::Cache;
+use Perlbal::Util;
 
 use fields (
@@ -27 +28 @@
             'listen',             # scalar IP:port of where we're listening for new connections
             'docroot',            # document root for webserver role
-            'dirindexing',        # bool: direcotry indexing?  (for webserver role)  not async.
+            'dirindexing',        # bool: directory indexing?  (for webserver role)  not async.
             'index_files',        # arrayref of filenames to try for index files
             'enable_concatenate_get',   # bool:  if user can request concatenated files
@@ -41 +42 @@
             'persist_backend', # bool: persistent connections for backends
             'verify_backend',  # bool: get attention of backend before giving it clients (using OPTIONS)
+            'verify_backend_path', # path to check with the OPTIONS request (default *)
             'max_backend_uses',  # max requests to send per kept-alive backend (default 0 = unlimited)
             'connect_ahead',           # scalar: number of spare backends to connect to in advance all the time
@@ -51 +53 @@
             'trusted_upstream_proxies', # Net::Netmask object containing netmasks for trusted upstreams
             'always_trusted', # bool; if true, always trust upstreams
+            'blind_proxy', # bool: if true, do not modify X-Forwarded-For, X-Host, or X-Forwarded-Host headers
             'enable_reproxy', # bool; if true, advertise that server will reproxy files and/or URLs
             'reproxy_cache_maxsize', # int; maximum number of reproxy results to be cached. (0 is disabled and default)
             'client_sndbuf_size',    # int: bytes for SO_SNDBUF
             'server_process' ,       # scalar: path to server process (executable)
+            'persist_client_timeout',  # int: keep-alive timeout in seconds for clients (default is 30)
 
             # Internal state:
@@ -60 +64 @@
             'waiting_clients_highpri', # arrayref of high-priority clients waiting for backendhttp conns
             'waiting_clients_lowpri',  # arrayref of low-priority clients waiting for backendhttp conns
-            'waiting_client_count',    # number of clients waiting for backendds
+            'waiting_client_count',    # number of clients waiting for backends
             'waiting_client_map'  ,    # map of clientproxy fd -> 1 (if they're waiting for a conn)
             'pending_connects',        # hashref of "ip:port" -> $time (only one pending connect to backend at a time)
@@ -77 +81 @@
             'buffer_backend_connect', # 0 for of, else, number of bytes to buffer before we ask for a backend
             'selector',    # CODE ref, or undef, for role 'selector' services
+            'default_service', # Perlbal::Service; name of a service a selector should default to
             'buffer_uploads', # bool; enable/disable the buffered uploads to disk system
             'buffer_uploads_path', # string; path to store buffered upload files
@@ -129 +134 @@
         check_role => "*",
         des => "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.",
-        check_type => ["regexp", qr/^\d+\.\d+\.\d+\.\d+:\d+$/, "Expecting IP:port of form a.b.c.d:port."],
+        check_type => ["regexp", qr/^(\d+\.\d+\.\d+\.\d+:)?\d+$/,
+                       "Listen argument must be ip:port or port. " .
+                       "e.g. 192.168.0.1:80 or 81"],
         setter => sub {
             my ($self, $val, $set, $mc) = @_;
@@ -169 +176 @@
         default => 0,
         check_type => "bool",
+        check_role => "reverse_proxy",
+    },
+    
+    'verify_backend_path' => {
+        des => "What path the OPTIONS request sent by verify_backend should use.  Default is '*'.",
+        default => '*',
         check_role => "reverse_proxy",
     },
@@ -316 +329 @@
 
     'enable_concatenate_get' => {
-        des => "Enable Perlbal's multiple-files-in-one-request mode, where a client have use a comma-separated list of files to return, always in text/plain.  Useful for webapps which have dozens/hundreds of tiny css/js files, and don't trust browsers/etc to do pipelining.  Decreases overall roundtrip latency a bunch, but requires app to be modified to support it.  See t/17-concat.t test for details.",
+        des => "Enable Perlbal's multiple-files-in-one-request mode, where a client have use a comma-separated list of files to return, always in text/plain.  Useful for web apps which have dozens/hundreds of tiny css/js files, and don't trust browsers/etc to do pipelining.  Decreases overall round-trip latency a bunch, but requires app to be modified to support it.  See t/17-concat.t test for details.",
         default => 0,
         check_role => "web_server",
@@ -339 +352 @@
         default => 0,
         check_type => "bool",
+        check_role => "*",
+    },
+
+    'blind_proxy' => {
+        des => "Flag to disable any modification of X-Forwarded-For, X-Host, and X-Forwarded-Host headers.",
+        default => 0,
+        check_type => "bool",
         check_role => "reverse_proxy",
     },
@@ -354 +374 @@
     'trusted_upstream_proxies' => {
         des => "A Net::Netmask filter (e.g. 10.0.0.0/24, see Net::Netmask) that determines whether upstream clients are trusted or not, where trusted means their X-Forwarded-For/etc headers are not munged.",
-        check_role => "reverse_proxy",
+        check_role => "*",
         check_type => sub {
             my ($self, $val, $errref) = @_;
@@ -366 +386 @@
             return 0;
         },
-
+        setter => sub {
+            my ($self, $val, $set, $mc) = @_;
+            # Do nothing here, we don't want the default setter because we've
+            # already set the value in the type_check step.
+            return $mc->ok;
+        },
     },
 
@@ -372 +397 @@
         check_role => "web_server",
         default => "index.html",
-        des => "Comma-seperated list of filenames to load when a user visits a directory URL, listed in order of preference.",
+        des => "Comma-separated list of filenames to load when a user visits a directory URL, listed in order of preference.",
         setter => sub {
             my ($self, $val, $set, $mc) = @_;
             $self->{index_files} = [ split(/[\s,]+/, $val) ];
             return $mc->ok;
+        },
+        dumper => sub {
+            my ($self, $val) = @_;
+            return join(', ', @$val);
+        },
+    },
+
+    'default_service' => {
+        des => "Name of previously-created service to default requests that aren't matched by a selector plugin to.",
+        check_role => "selector",
+        check_type => sub {
+            my ($self, $val, $errref) = @_;
+
+            my $svc = Perlbal->service($val);
+            unless ($svc) {
+                $$errref = "Service '$svc' not found";
+                return 0;
+            }
+
+            $self->{default_service} = $svc;
+            return 1;
+        }, 
+        setter => sub {
+            # override default so we don't set it to the text
+            return $_[3]->ok;
         },
     },
@@ -403 +453 @@
             return $mc->ok;
         },
+        dumper => sub {
+            my ($self, $val) = @_;
+            return $val->name;
+        }
     },
 
@@ -417 +471 @@
     },
 
+    'persist_client_timeout' => {
+        des => "Timeout in seconds for HTTP keep-alives to the end user (default is 30)",
+        check_type => "int",
+        default => 30,
+        check_role => "*",
+    },
+    
     'buffer_uploads_path' => {
         des => "Directory root for storing files used to buffer uploads.",
@@ -565 +626 @@
 
     return $self;
+}
+
+# handy instance method to run some manage commands in the context of this service,
+# without needing to worry about its name.
+# This is intended as an internal API thing, so any output that would have been
+# generated is just eaten.
+sub run_manage_commands {
+    my ($self, $cmd_block) = @_;
+
+    my $ctx = Perlbal::CommandContext->new;
+    $ctx->{last_created} = $self->name;
+    return Perlbal::run_manage_commands($cmd_block, undef, $ctx);
+}
+
+# here's an alternative version of the above that runs a single command
+sub run_manage_command {
+    my ($self, $cmd) = @_;
+
+    my $ctx = Perlbal::CommandContext->new;
+    $ctx->{last_created} = $self->name;
+    return Perlbal::run_manage_command($cmd, undef, $ctx);
+}
+
+sub dumpconfig {
+    my $self = shift;
+
+    my @return;
+
+    my %my_tunables = %$tunables;
+
+    my $dump = sub {
+        my $setting = shift;
+    };
+
+    foreach my $skip (qw(role listen pool)) {
+        delete $my_tunables{$skip};
+    }
+
+    my $role = $self->{role};
+
+    foreach my $setting ("role", "listen", "pool", sort keys %my_tunables) {
+        my $attrs = $tunables->{$setting};
+        my $value = $self->{$setting};
+
+        my $check_role = $attrs->{check_role};
+        my $check_type = $attrs->{check_type};
+        my $default    = $attrs->{default};
+        my $required   = $attrs->{required};
+
+        next if ($check_role && $check_role ne '*' && $check_role ne $role);
+
+        if ($check_type && $check_type eq 'size') {
+            $default = $1               if $default =~ /^(\d+)b$/i;
+            $default = $1 * 1024        if $default =~ /^(\d+)k$/i;
+            $default = $1 * 1024 * 1024 if $default =~ /^(\d+)m$/i;
+        }
+
+        if (!$required) {
+            next unless defined $value;
+            next if (defined $default && $value eq $default);
+        }
+
+        if (my $dumper = $attrs->{dumper}) {
+            $value = $dumper->($self, $value);
+        }
+
+        if ($check_type && $check_type eq 'bool') {
+            $value = 'on' if $value;
+        }
+
+        push @return, "SET $setting = $value";
+    }
+
+    my $plugins = $self->{plugins};
+
+    foreach my $plugin (keys %$plugins) {
+        local $@;
+
+        my $class = "Perlbal::Plugin::$plugin";
+        my $cv = $class->can('dumpconfig');
+
+        if ($cv) {
+            eval { push @return, $class->dumpconfig($self) };
+            if ($@) {
+                push @return, "# Plugin '$plugin' threw an exception while being dumped.";
+            }
+        } else {
+            push @return, "# Plugin '$plugin' isn't capable of dumping config.";
+        }
+    }
+
+    return @return;
 }
 
@@ -1191 +1344 @@
             if (my $sp = $self->{server_process}) {
                 warn "To create = $to_create...\n";
-                warn "  spawing $sp\n";
+                warn "  spawning $sp\n";
                 my $be = Perlbal::BackendHTTP->new_process($self, $sp);
                 return;
@@ -1260 +1413 @@
     return $mc->err("no header provided") unless $key;
     return $mc->err("no value provided")  unless $val || $mode eq 'remove';
+    return $mc->err("only valid on reverse_proxy services") unless $self->{role} eq 'reverse_proxy';
 
     if ($mode eq 'insert') {
@@ -1287 +1441 @@
 sub selector {
     my Perlbal::Service $self = shift;
-    $self->{selector} = shift if @_;
+    if (@_) {
+        my $ref = shift;
+        $self->{selector} = sub {
+            my $cb = shift;
+
+            # try to give it to our defined selector
+            my $res = $ref->($cb);
+
+            # if that failed and we have a default, then give it to them
+            if (!$res && $self->{default_service}) {
+                $self->{default_service}->adopt_base_client($cb);
+                return 1;
+            }
+
+            return $res;
+        };
+    }
     return $self->{selector};
 }
@@ -1304 +1474 @@
         Perlbal::ClientProxy->new_from_base($cb);
         return;
+    } elsif ($self->{'role'} eq "selector") {
+        $self->selector()->($cb);
+        return;
     } else {
         $cb->_simple_response(500, "Can't map to service type $self->{'role'}");
@@ -1316 +1489 @@
 
     $cb->{service} = $self;
-    bless $cb, "Perlbal::ClientHTTPBase";
+    Perlbal::Util::rebless($cb, "Perlbal::ClientHTTPBase");
 
     # the read/watch events are reset by ClientHTTPBase's http_response_sent (our caller)

trunk/server/lib/mogdeps/Perlbal/Socket.pm

@@ -1 +1 @@
 # Base class for all socket types
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 
 package Perlbal::Socket;
@@ -33 +33 @@
 
             'ditch_leading_rn', # if true, the next header parsing will ignore a leading \r\n
+
+            'observed_ip_string', # if defined, contains the observed IP string of the peer
+                                  # we're serving. this is intended for hoding the value of
+                                  # the X-Forwarded-For and using it to govern ACLs.
             );
 
@@ -107 +111 @@
 
             # however, the grep turned our weak references back into strong ones, so
-            # we have to reweaken them
+            # we have to re-weaken them
             weaken($_) foreach @created_objects;
 
@@ -132 +136 @@
     my $now = time;
 
-    my %max_age;  # classname -> max age (0 means forever)
     my @to_close;
     while (my $k = each %$sf) {
         my Perlbal::Socket $v = $sf->{$k};
-        my $ref = ref $v;
-        unless (defined $max_age{$ref}) {
-            # eval because not all Danga::Socket connections in Perlbal
-            # must be Perlbal::Socket-derived
-            $max_age{$ref} = eval { $ref->max_idle_time } || 0;
-        }
-        next unless $max_age{$ref};
-        if ($v->{alive_time} < $now - $max_age{$ref}) {
+
+        my $max_age = eval { $v->max_idle_time } || 0;
+        next unless $max_age;
+
+        if ($v->{alive_time} < $now - $max_age) {
             push @to_close, $v;
         }
@@ -220 +220 @@
     $self->{headers_string} .= $$bref;
     my $idx = index($self->{headers_string}, "\r\n\r\n");
-
-    # can't find the header delimiter?
+    my $delim_len = 4;
+
+    # can't find the header delimiter? check for LFLF header delimiter.
+    if ($idx == -1) {
+        $idx = index($self->{headers_string}, "\n\n");
+        $delim_len = 2;
+    }
+    # still can't find the header delimiter?
     if ($idx == -1) {
 
@@ -244 +250 @@
     print "  pre-parsed headers: [$hstr]\n" if Perlbal::DEBUG >= 3;
 
-    my $extra = substr($self->{headers_string}, $idx+4);
+    my $extra = substr($self->{headers_string}, $idx+$delim_len);
     if (my $len = length($extra)) {
         print "  pushing back $len bytes after header\n" if Perlbal::DEBUG >= 3;
@@ -296 +302 @@
 }
 
+### METHOD: write()
+### Overridden from Danga::Socket to update our alive time on successful writes
+### Stops sockets from being closed on long-running write operations
+sub write {
+    my $self = shift;
+
+    my $ret;
+    if ($ret = $self->SUPER::write(@_)) {
+        # Mark this socket alive so we don't time out
+        $self->{alive_time} = $Perlbal::tick_time;
+    }
+    
+    return $ret;
+}
+
 ### METHOD: close()
 ### Set our state when we get closed.
@@ -314 +335 @@
 }
 
+sub observed_ip_string {
+    my Perlbal::Socket $self = shift;
+
+    if (@_) {
+        return $self->{observed_ip_string} = $_[0];
+    } else {
+        return $self->{observed_ip_string};
+    }
+}
+
 sub as_string_html {
     my Perlbal::Socket $self = shift;

trunk/server/lib/mogdeps/Perlbal/TCPListener.pm

@@ -2 +2 @@
 # TCP listener on a given port
 #
-# Copyright 2004, Danga Interactice, Inc.
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2004, Danga Interactive, Inc.
+# Copyright 2005-2007, Six Apart, Ltd.
 
 
@@ -12 +12 @@
 
 use base "Perlbal::Socket";
-use fields qw(service hostport);
+use fields ('service',
+            'hostport',
+            'sslopts',
+            'v6',  # bool: IPv6 libraries are available
+            );
 use Socket qw(IPPROTO_TCP SOL_SOCKET SO_SNDBUF);
+
+BEGIN {
+    eval { require Perlbal::SocketSSL };
+    if (Perlbal::DEBUG > 0 && $@) { warn "SSL support failed on load: $@\n" }
+}
 
 # TCPListener
 sub new {
-    my ($class, $hostport, $service, $opts) = @_;
+    my Perlbal::TCPListener $self = shift;
+    my ($hostport, $service, $opts) = @_;
+
+    $self = fields::new($self) unless ref $self;
     $opts ||= {};
 
-    my $sockclass = $opts->{ssl} ? "IO::Socket::SSL" : "IO::Socket::INET";
-    my $sock = eval {
-        $sockclass->new(
-                        LocalAddr => $hostport,
-                        Proto => IPPROTO_TCP,
-                        Listen => 1024,
-                        ReuseAddr => 1,
-                        ($opts->{ssl} ? %{$opts->{ssl}} : ()),
-                        );
-    };
+    # Were ipv4 or ipv6 explicitly mentioned by syntax?
+    my $force_v4 = 0;
+    my $force_v6 = 0;
+
+    my @args;
+    if ($hostport =~ /^\d+$/) {
+        @args = ('LocalPort' => $hostport);
+    } elsif ($hostport =~ /^\d+\.\d+\.\d+\.\d+:/) {
+        $force_v4 = 1;
+        @args = ('LocalAddr' => $hostport);
+    }
+
+    my $v6_errors = "";
+
+    my $can_v6 = 0;
+    if (!$force_v4) {
+        eval "use Danga::Socket 1.61; 1; ";
+        if ($@) {
+            $v6_errors = "Danga::Socket 1.61 required for IPv6 support.";
+        } elsif (!eval { require IO::Socket::INET6; 1 }) {
+            $v6_errors = "IO::Socket::INET6 required for IPv6 support.";
+        } else {
+            $can_v6 = 1;
+        }
+    }
+
+    my $socket_class = $can_v6 ? "IO::Socket::INET6" : "IO::Socket::INET";
+    $self->{v6} = $can_v6;
+
+    my $sock = $socket_class->new(
+                                  @args,
+                                  Proto => IPPROTO_TCP,
+                                  Listen => 1024,
+                                  ReuseAddr => 1,
+                                  );
 
     return Perlbal::error("Error creating listening socket: " . ($@ || $!))
@@ -46 +83 @@
     }
 
-    my $self = $class->SUPER::new($sock);
+    $self->SUPER::new($sock);
     $self->{service} = $service;
     $self->{hostport} = $hostport;
-    bless $self, ref $class || $class;
+    $self->{sslopts} = $opts->{ssl};
     $self->watch_read(1);
     return $self;
@@ -60 +97 @@
     # accept as many connections as we can
     while (my ($psock, $peeraddr) = $self->{sock}->accept) {
-        my $service_role = $self->{service}->role;
-
-        if (Perlbal::DEBUG >= 1) {
-            my ($pport, $pipr) = Socket::sockaddr_in($peeraddr);
-            my $pip = Socket::inet_ntoa($pipr);
-            print "Got new conn: $psock ($pip:$pport) for $service_role\n";
-        }
-
         IO::Handle::blocking($psock, 0);
 
@@ -74 +103 @@
         }
 
-        if ($service_role eq "reverse_proxy") {
-            Perlbal::ClientProxy->new($self->{service}, $psock);
-        } elsif ($service_role eq "management") {
-            Perlbal::ClientManage->new($self->{service}, $psock);
-        } elsif ($service_role eq "web_server") {
-            Perlbal::ClientHTTP->new($self->{service}, $psock);
-        } elsif ($service_role eq "selector") {
-            # will be cast to a more specific class later...
-            Perlbal::ClientHTTPBase->new($self->{service}, $psock, $self->{service});
-        } elsif (my $creator = Perlbal::Service::get_role_creator($service_role)) {
-            # was defined by a plugin, so we want to return one of these
-            $creator->($self->{service}, $psock);
+        if (Perlbal::DEBUG >= 1) {
+            my ($pport, $pipr) = $self->{v6} ?
+                Socket6::unpack_sockaddr_in6($peeraddr) :
+                Socket::sockaddr_in($peeraddr);
+            my $pip = $self->{v6} ?
+                "[" . Socket6::inet_ntop(Socket6::AF_INET6(), $pipr) . "]" :
+                Socket::inet_ntoa($pipr);
+            print "Got new conn: $psock ($pip:$pport) for " . $self->{service}->role . "\n";
         }
 
+        # SSL promotion if necessary
+        if ($self->{sslopts}) {
+            # try to upgrade to SSL, this does no IO it just re-blesses
+            # and prepares the SSL engine for handling us later
+            IO::Socket::SSL->start_SSL(
+                                       $psock,
+                                       SSL_server => 1,
+                                       SSL_startHandshake => 0,
+                                       %{ $self->{sslopts} },
+                                       );
+            print "  .. socket upgraded to SSL!\n" if Perlbal::DEBUG >= 1;
+
+            # safety checking to ensure we got upgraded
+            return $psock->close
+                unless ref $psock eq 'IO::Socket::SSL';
+
+            # class into new package and run with it
+            my $sslsock = new Perlbal::SocketSSL($psock, $self);
+            $sslsock->try_accept;
+
+            # all done from our point of view
+            next;
+        }
+
+        # puts this socket into the right class
+        $self->class_new_socket($psock);
+    }
+}
+
+sub class_new_socket {
+    my Perlbal::TCPListener $self = shift;
+    my $psock = shift;
+
+    my $service_role = $self->{service}->role;
+    if ($service_role eq "reverse_proxy") {
+        Perlbal::ClientProxy->new($self->{service}, $psock);
+    } elsif ($service_role eq "management") {
+        Perlbal::ClientManage->new($self->{service}, $psock);
+    } elsif ($service_role eq "web_server") {
+        Perlbal::ClientHTTP->new($self->{service}, $psock);
+    } elsif ($service_role eq "selector") {
+        # will be cast to a more specific class later...
+        Perlbal::ClientHTTPBase->new($self->{service}, $psock, $self->{service});
+    } elsif (my $creator = Perlbal::Service::get_role_creator($service_role)) {
+        # was defined by a plugin, so we want to return one of these
+        $creator->($self->{service}, $psock);
     }
 }
@@ -113 +184 @@
 }
 
-
 1;
 

trunk/server/lib/mogdeps/Perlbal/Test.pm

@@ +1 @@
+#!/usr/bin/perl -w
+
 package Perlbal::Test;
+
+=head1 NAME
+
+Perlbal::Test - Test harness for perlbal server
+
+=head1 SYNOPSIS
+
+#  my $msock = Perlbal::Test::start_server();
+
+=head1 DESCRIPTION
+
+Perlbal::Test provides access to a perlbal server running on the
+local host, for testing purposes.
+
+The server can be an already-existing server, a child process, or
+the current process.
+
+Various functions are provided to interact with the server.
+
+=head1 FUNCTIONS
+
+=cut
+
 use strict;
 use POSIX qw( :sys_wait_h );
 use IO::Socket::INET;
+use Socket qw(MSG_NOSIGNAL IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
 use HTTP::Response;
 
@@ -9 +35 @@
 @ISA = qw(Exporter);
 @EXPORT = qw(ua start_server foreach_aio manage filecontent tempdir new_port
+             manage_multi
              mgmt_port wait_on_child dump_res resp_from_sock msock);
 
@@ -18 +45 @@
 our $free_port = 60000;
 
-sub mgmt_port { return $mgmt_port; }
+=head1 I<mgmt_port()>
+
+Return the current management port number.
+
+=cut
+
+sub mgmt_port {
+        return $mgmt_port;
+}
 
 END {
     manage("shutdown") if $i_am_parent;
 }
+
+=head1 I<dump_res($http_response)>
+
+Return a readable string formatted from an HTTP::Response object.
+Only the first 80 characters of returned content are returned.
+
+=cut
 
 sub dump_res {
@@ -42 +84 @@
 }
 
+=head1 I<tempdir()>
+
+Return a newly created temporary directory. The directory will be
+removed automatically upon program exit.
+
+=cut
+
 sub tempdir {
     require File::Temp;
@@ -47 +96 @@
 }
 
+=head1 I<new_port()>
+
+Return the next free port number in the series. Port numbers are assigned
+starting at 60000.
+
+=cut
+
 sub new_port {
-    return $free_port++;  # FIXME: make it somehow detect if port is in use?
-}
+    test_port() ? return $free_port++ : return new_port($free_port++);
+}
+
+=head1 I<test_port()>
+
+Return 1 if the port is free to use for listening on $free_port else return 0.
+
+=cut
+
+sub test_port {
+    my $sock = IO::Socket::INET->new(LocalPort => $free_port) or return 0;
+    $sock->close();
+    return 1;
+}
+
+=head1 I<filecontent($file>>
+
+Return a string containing the contents of the file $file. If $file
+cannot be opened, then return undef.
+
+=cut
 
 sub filecontent {
@@ -60 +135 @@
 }
 
+=head1 I<foreach_aio($callback)>
+
+Set the server into each AIO mode (none, ioaio) and call the specified
+callback function with the mode name as argument.
+
+=cut
+
 sub foreach_aio (&) {
     my $cb = shift;
 
-    foreach my $mode (qw(none linux ioaio)) {
+    foreach my $mode (qw(none ioaio)) {
         my $line = manage("SERVER aio_mode = $mode");
         next unless $line;
@@ -70 +152 @@
 }
 
+=head1 I<manage($cmd, %opts)>
+
+Send a command $cmd to the server, and return the response line from
+the server.
+
+Optional arguments are:
+
+  quiet_failure => 1
+
+Output a warning if the response indicated an error,
+unless $opts{quiet_failure} is true, or the command
+was 'shutdown' (which doesn't return a response).
+
+=cut
+
 sub manage {
     my $cmd = shift;
+    my %opts = @_;
+
     print $msock "$cmd\r\n";
     my $res = <$msock>;
+
+    if (!$res || $res =~ /^ERR/) {
+        # Make the result visible in failure cases, unless
+        # the command was 'shutdown'... cause that never
+        # returns anything.
+        warn "Manage command failed: '$cmd' '$res'\n"
+            unless($opts{quiet_failure} || $cmd eq 'shutdown');
+
+        return 0;
+    }
+    return $res;
+}
+
+=head1 I<manage_multi($cmd)>
+
+Send a command $cmd to the server, and return a multi-line
+response. Return the number zero if there was an error or
+no response.
+
+=cut
+
+sub manage_multi {
+    my $cmd = shift;
+
+    print $msock "$cmd\r\n";
+    my $res;
+    while (<$msock>) {
+        last if /^\./;
+        last if /^ERROR/;
+        $res .= $_;
+    }
     return 0 if !$res || $res =~ /^ERR/;
     return $res;
 }
+
+=head1 I<start_server($conf)>
+
+Optionally start a perlbal server and return a socket connected to its
+management port.
+
+The argument $conf is a string specifying initial configuration
+commands.
+
+If the environment variable TEST_PERLBAL_FOREGROUND is set to a true
+value then a server will be started in the foreground, in which case
+this function does not return. When the server function finishes,
+exit() will be called to terminate the process.
+
+If the environment variable TEST_PERLBAL_USE_EXISTING is set to a true
+value then a socket will be returned which is connected to an existing
+server's management port.
+
+Otherwise, a child process is forked and a socket is returned which is
+connected to the child's management port.
+
+The management port is assigned automatically, a new port number each
+time this function is called. The starting port number is 60000.
+
+=cut
 
 sub start_server {
@@ -117 +272 @@
 }
 
+# Start a perlbal server running and tell it to listen on the specified
+# management port number. This function does not return.
+
 sub _start_perbal_server {
     my ($conf, $mgmt_port) = @_;
@@ -140 +298 @@
 }
 
-# get the manager socket
+
+=head1 I<msock()>
+
+Return a reference to the socket connected to the server's management
+port.
+
+=cut
+
 sub msock {
     return $msock;
 }
+
+
+=head1 I<ua()>
+
+Return a new instance of LWP::UserAgent.
+
+=cut
 
 sub ua {
@@ -150 +322 @@
     return LWP::UserAgent->new;
 }
+
+=head1 I<wait_on_child($pid, $port)>
+
+Return a socket which is connected to a child process.
+
+$pid specifies the child process id, and $port is the port number on
+which the child is listening.
+
+Several attempts are made; if the child dies or a connection cannot
+be made within 5 seconds then this function dies with an error message.
+
+=cut
 
 sub wait_on_child {
@@ -167 +351 @@
 }
 
+=head1 I<resp_from_sock($sock)>
+
+Read an HTTP response from a socket and return it
+as an HTTP::Response object
+
+In scalar mode, return only the $http_response object.
+
+In array mode, return an array of ($http_response, $firstline) where
+$firstline is the first line read from the socket, for example:
+
+"HTTP/1.1 200 OK"
+
+=cut
+
 sub resp_from_sock {
     my $sock = shift;

trunk/server/lib/mogdeps/Perlbal/Test/WebClient.pm

@@ -29 +29 @@
     my $self = shift;
     if (@_) {
+        $self->{_sock} = undef;
         return $self->{server} = shift;
     } else {
@@ -39 +40 @@
     my $self = shift;
     if (@_) {
+        $self->{_sock} = undef;
         return $self->{host} = shift;
     } else {

trunk/server/lib/mogdeps/Perlbal/UploadListener.pm

@@ -2 +2 @@
 # Listen for UDP upload status packets
 #
-# Copyright 2005-2006, Six Apart, Ltd.
+# Copyright 2005-2007, Six Apart, Ltd.
 
 
@@ -27 +27 @@
     return Perlbal::error("Error creating listening socket: " . ($@ || $!))
         unless $sock;
-
-    my $self = $class->SUPER::new($sock);
+    my $self = fields::new($class);
+    $self->SUPER::new($sock);
     $self->{service} = $service;
     $self->{hostport} = $hostport;
-    bless $self, ref $class || $class;
     $self->watch_read(1);
     return $self;

trunk/server/lib/mogdeps/Perlbal/Util.pm

@@ -9 +9 @@
 sub durl {
     my ($txt) = @_;
-    $txt =~ tr/+/ /;
     $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;
+        };
+    }
 }