Skip to content
This repository

Support for randomized reqs-per-child #49

Open
wants to merge 9 commits into from

2 participants

Masahiro Nagano Tatsuhiko Miyagawa
This page is out of date. Refresh to see the latest.
24 lib/Starman/Server.pm
@@ -157,6 +157,12 @@ sub run_parent {
157 157 sub child_init_hook {
158 158 my $self = shift;
159 159 srand();
  160 +
  161 + my $max_requests = $self->{server}->{max_requests};
  162 + if ( my $min_requests = $self->{options}->{min_requests} ) {
  163 + $self->{server}->{max_requests} = $max_requests - int(($max_requests - $min_requests + 1) * rand);
  164 + }
  165 +
160 166 if ($self->{options}->{psgi_app_builder}) {
161 167 DEBUG && warn "[$$] Initializing the PSGI app\n";
162 168 $self->{app} = $self->{options}->{psgi_app_builder}->();
@@ -164,6 +170,12 @@ sub child_init_hook {
164 170 $0 = "starman worker " . join(" ", @{$self->{options}{argv} || []});
165 171 }
166 172
  173 +sub child_finish_hook {
  174 + my $self = shift;
  175 + my $prop = $self->{'server'};
  176 + $self->log(4, "Child leaving ($prop->{'max_requests'})");
  177 +}
  178 +
167 179 sub post_accept_hook {
168 180 my $self = shift;
169 181
@@ -516,7 +528,11 @@ sub _finalize_response {
516 528 return unless $len;
517 529 $buffer = sprintf( "%x", $len ) . $CRLF . $buffer . $CRLF;
518 530 }
519   - syswrite $conn, $buffer;
  531 + while ( length $buffer ) {
  532 + my $len = syswrite $conn, $buffer;
  533 + die "write error: $!" if ! defined $len;
  534 + substr( $buffer, 0, $len, '');
  535 + }
520 536 DEBUG && warn "[$$] Wrote " . length($buffer) . " bytes\n";
521 537 });
522 538
@@ -530,7 +546,11 @@ sub _finalize_response {
530 546 return unless $len;
531 547 $buffer = sprintf( "%x", $len ) . $CRLF . $buffer . $CRLF;
532 548 }
533   - syswrite $conn, $buffer;
  549 + while ( length $buffer ) {
  550 + my $len = syswrite $conn, $buffer;
  551 + die "write error: $!" if ! defined $len;
  552 + substr( $buffer, 0, $len, '');
  553 + }
534 554 DEBUG && warn "[$$] Wrote " . length($buffer) . " bytes\n";
535 555 },
536 556 close => sub {
5 script/starman
@@ -122,6 +122,11 @@ failover (see above).
122 122
123 123 Number of the requests to process per one worker process. Defaults to 1000.
124 124
  125 +=item --min-requests
  126 +
  127 +if set, randomizes the number of requests handled by a single worker
  128 +process between the value and that supplied by --max-requests (default: none)
  129 +
125 130 =item --preload-app
126 131
127 132 This option lets Starman preload the specified PSGI application in the
48 t/randomized_per_child.t
... ... @@ -0,0 +1,48 @@
  1 +use strict;
  2 +use warnings;
  3 +use Test::TCP;
  4 +use LWP::UserAgent;
  5 +use FindBin;
  6 +use Test::More;
  7 +use File::Temp qw/tempfile/;
  8 +
  9 +my $max = 5;
  10 +my $min = 3;
  11 +local $ENV{STARMAN_DEBUG} = 1;
  12 +
  13 +my ($error_fh , $error_log) = tempfile(CLEANUP=>0);
  14 +close $error_fh;
  15 +
  16 +my $s = Test::TCP->new(
  17 + code => sub {
  18 + my $port = shift;
  19 + open STDERR, '>>', $error_log;
  20 + exec "$^X bin/starman --port $port --max-requests=$max --min-requests=$min --workers=1 '$FindBin::Bin/rand.psgi'";
  21 + },
  22 +);
  23 +
  24 +my $ua = LWP::UserAgent->new;
  25 +for (1..100) {
  26 + $ua->get("http://localhost:" . $s->port);
  27 +}
  28 +
  29 +open( my $fh, $error_log) or die $!;
  30 +my ($req_min, $req_max) = ($min, $max);
  31 +my $n;
  32 +while ( my $log = <$fh> ) {
  33 + if ( $log =~ m!Child leaving \((\d+)\)! ) {
  34 + $n = $1;
  35 + $min = $n
  36 + if $n < $req_min;
  37 + $max = $n
  38 + if $n > $req_max;
  39 + }
  40 +}
  41 +
  42 +ok $n;
  43 +is $req_min, $min, "min";
  44 +is $req_max, $max, "max";
  45 +unlink $error_log;
  46 +done_testing();
  47 +
  48 +
54 t/ssl_largebody.t
... ... @@ -0,0 +1,54 @@
  1 +use strict;
  2 +use Test::More;
  3 +use Test::Requires 'LWP::Protocol::https';
  4 +use Test::TCP;
  5 +use LWP::UserAgent;
  6 +use FindBin '$Bin';
  7 +use Starman::Server;
  8 +
  9 +# https://github.com/miyagawa/Starman/issues/78
  10 +
  11 +my $host = 'localhost';
  12 +my $ca_cert = "$Bin/ssl_ca.pem";
  13 +my $server_pem = "$Bin/ssl_key.pem";
  14 +my $body = 'x'x32*1024; # > 16KB
  15 +
  16 +my ($success, $status, $content);
  17 +
  18 +test_tcp(
  19 + client => sub {
  20 + my $port = shift;
  21 +
  22 + my $ua = LWP::UserAgent->new(
  23 + timeout => 2,
  24 + ssl_opts => {
  25 + verify_hostname => 1,
  26 + SSL_ca_file => $ca_cert,
  27 + },
  28 + );
  29 +
  30 + my $res = $ua->get("https://$host:$port");
  31 + $success = $res->is_success;
  32 + $status = $res->status_line;
  33 + $content = $res->decoded_content;
  34 + },
  35 + server => sub {
  36 + my $port = shift;
  37 + Starman::Server->new->run(
  38 + sub { [ 200, [], [$body] ] },
  39 + {
  40 + host => $host,
  41 + port => $port,
  42 + ssl => 1,
  43 + ssl_key => $server_pem,
  44 + ssl_cert => $server_pem,
  45 + },
  46 + );
  47 + }
  48 +);
  49 +
  50 +ok $success, 'HTTPS connection succeeded';
  51 +diag $status if not $success;
  52 +is $content, $body;
  53 +
  54 +done_testing;

Tip: You can add notes to lines in a file. Hover to the left of a line to make a note

Something went wrong with that request. Please try again.