Make READ_TIMEOUT configurable on the command line

Changes

@@ -1,5 +1,9 @@
 Revision history for Perl extension Starman
 
+        - Made READ_TIMEOUT configurable, allowing Starman to sit nicely
+          behind balancer keeping backend connections open for a long time
+          (Yann Kerherve)
+
 0.29_90 Thu Dec  1 19:40:52 PST 2011
         - Changed the way server handles HUP and QUIT signals
           HUP will just restart all the workers gracefully

bin/starman

@@ -154,6 +154,17 @@ with idle clients.
 
 Defaults to 1.
 
+=item --read-timeout
+
+The number of seconds Starman will wait to read one request headers.
+Setting this to a high value is beneficial if Starman sits behind
+a load balancer pre-opening connections (like Perlbal with connect-ahead
+option set). On the other hand, if you don't have such balancer, it can DOS
+your application if enough slow clients connect at the same time and starve
+your workers.
+
+Defaults to 5.
+
 =item --user
 
 To listen on a low-numbered (E<lt>1024) port, it will be necessary to

lib/Starman/Server.pm

@@ -13,9 +13,9 @@ use Symbol;
 use Plack::Util;
 use Plack::TempBuffer;
 
-use constant DEBUG        => $ENV{STARMAN_DEBUG} || 0;
-use constant CHUNKSIZE    => 64 * 1024;
-use constant READ_TIMEOUT => 5;
+use constant DEBUG                => $ENV{STARMAN_DEBUG} || 0;
+use constant CHUNKSIZE            => 64 * 1024;
+use constant DEFAULT_READ_TIMEOUT => 5;
 
 my $null_io = do { open my $io, "<", \""; $io };
 
@@ -47,6 +47,17 @@ sub run {
         $options->{keepalive_timeout} = 1;
     }
 
+    if (! exists $options->{read_timeout}) {
+        $options->{read_timeout} = DEFAULT_READ_TIMEOUT;
+    }
+    else {
+        my $read_timeout = $options->{read_timeout};
+        if (! $read_timeout or $read_timeout < 0) {
+            warn "invalid --read-timeout=$read_timeout. ignoring\n";
+            $options->{read_timeout} = DEFAULT_READ_TIMEOUT;
+        }
+    }
+
     my($host, $port, $proto);
     for my $listen (@{$options->{listen} || [ "$options->{host}:$options->{port}" ]}) {
         if ($listen =~ /:/) {
@@ -301,7 +312,7 @@ sub _read_headers {
     eval {
         local $SIG{ALRM} = sub { die "Timed out\n"; };
 
-        alarm( READ_TIMEOUT );
+        alarm( $self->{options}{read_timeout} );
 
         while (1) {
             # Do we have a full header in the buffer?

t/read_timeout.t

@@ -0,0 +1,31 @@
+use Test::TCP;
+use FindBin;
+use Test::More;
+use IO::Socket ':crlf';
+use Time::HiRes qw(tv_interval gettimeofday);
+
+for my $timeout (qw(1 2 5)) {
+    my $s = Test::TCP->new(
+        code => sub {
+            my $port = shift;
+            exec "$^X bin/starman --read-timeout=$timeout --port $port --workers=1 $FindBin::Bin/rand.psgi";
+        },
+    );
+
+    my $port = $s->port;
+    my $sock = IO::Socket::INET->new("localhost:$port");
+    my $t0 = [gettimeofday];
+    print $sock "GET /incomplete_headers HTTP/1.0$CRLF";
+    my $nr = read $sock, my $response, 1024;
+    my $iv = tv_interval($t0);
+    is $response, '', 'no data back';
+    if ($!) {
+        skip 2, "I/O error";
+    }
+    ok(defined($nr) && $nr == 0, 'no data back');
+    my $error_margin = sprintf "%.3f", abs($iv - $timeout) / $iv;
+    my $is_close = $error_margin < 0.05 ? 1 : 0;
+    ok $is_close, "timeout roughly $timeout ($error_margin)";
+}
+
+done_testing;