Merge pull request #20 from Troglodyne-Internet-Widgets/answer-before-hup

Answer the connection a worker took before a HUP retires it

bin/tarbaby

@@ -32,7 +32,7 @@ Getopt::Long::GetOptions(
     "preload-app"      => \$preload_app,
 );
 
-my @args = (server => 'Starman', env => 'deployment', version_cb => \&version);
+my @args = (server => 'TPSGI', env => 'deployment', version_cb => \&version);
 if (!$preload_app) {
         push @args, 'loader' => 'Delayed';
 }

lib/Plack/Handler/TPSGI.pm

@@ -0,0 +1,35 @@
+package Plack::Handler::TPSGI;
+
+use strict;
+use warnings;
+
+use parent qw{Plack::Handler::Starman};
+
+use TPSGI::Server;
+
+=head1 Plack::Handler::TPSGI
+
+Plack::Handler::Starman, running TPSGI::Server instead of Starman::Server.
+bin/tarbaby asks Plack::Runner for it as C<server =E<gt> 'TPSGI'>.
+
+=head2 run($app)
+
+Plack::Handler::Starman::run() names Starman::Server outright, so this is
+that, less its Server::Starter support, which tPSGI does not use.
+
+=cut
+
+sub run {
+    my ( $self, $app ) = @_;
+
+    my %nsa;
+    foreach my $key ( keys %$self ) {
+        ( my $name = $key ) =~ s/^net_server_// or next;
+        $nsa{$name} = $self->{$key};
+    }
+    $self->{net_server_args} = \%nsa if %nsa;
+
+    return TPSGI::Server->new->run( $app, {%$self} );
+}
+
+1;

lib/TPSGI/Server.pm

@@ -0,0 +1,72 @@
+package TPSGI::Server;
+
+use strict;
+use warnings;
+
+use parent qw{Starman::Server};
+
+=head1 TPSGI::Server
+
+Starman::Server, with workers that answer every connection they accept before
+a HUP retires them.
+
+=head2 Why
+
+A HUP to Starman's parent sends HUP to every worker.  Net::Server::PreFork's
+handler for it exits on the spot unless the worker is C<connected>, and
+run_child() only sets that flag in the statement after accept() returns.  Perl
+runs the handler between those two, so a worker which had just accepted a
+connection exited holding it: the kernel reset the connection, and nginx
+answered the client with a 502.  tPSGI HUPs its parent after every save, and
+the browser's next request lands exactly then.
+
+Here the handler only marks the worker HUPed and done, and accept() returns 1
+whenever it is holding a connection.  A worker blocked in accept() still
+retires at once, since the HUP interrupts the accept and nothing was taken.  One
+which took a connection answers it, and done() retires it afterwards, as it
+does a worker that was busy when the HUP came.
+
+This depends on how Net::Server's accept() and run_child() use C<_HUP>,
+C<SigHUPed> and C<client>.  t/TPSGI-Server.t pins that.
+
+=head2 child_init_hook
+
+Starman's, then the HUP handler described above.  It replaces the one
+Net::Server::PreFork installs in run_child(), which runs before this hook.
+
+=cut
+
+sub child_init_hook {
+    my $self = shift;
+    $self->SUPER::child_init_hook(@_);
+
+    my $prop = $self->{server};
+    $SIG{HUP} = sub {
+        $prop->{SigHUPed} = 1;
+
+        # Makes Net::Server's accept() return rather than retry, so a worker
+        # waiting in it retires now instead of after its next request.
+        $prop->{_HUP} = 1;
+    };
+    return;
+}
+
+=head2 accept() = BOOL
+
+True when there is a connection to answer, even when a HUP made
+Net::Server::accept() say otherwise.
+
+=cut
+
+sub accept {    ## no critic (ProhibitBuiltinHomonyms) -- Net::Server's method, overridden
+    my $self = shift;
+    my $prop = $self->{server};
+
+    # So a connection from the last request cannot pass for a new one.
+    delete $prop->{client};
+
+    return 1 if $self->SUPER::accept(@_);
+    return $prop->{client} ? 1 : 0;
+}
+
+1;

t/TPSGI-Server.t

@@ -0,0 +1,96 @@
+use strict;
+use warnings;
+
+use Test2::V0;
+use Test2::Plugin::NoWarnings;
+
+use Cwd            qw{abs_path};
+use File::Basename qw{dirname};
+use Test::MockModule;
+
+use lib dirname( abs_path(__FILE__) ) . '/../lib';
+
+ok( require TPSGI::Server, 'TPSGI::Server loads' ) or bail_out("Can't find SUT");
+
+sub server { return bless( { server => {@_} }, 'TPSGI::Server' ) }
+
+subtest 'child_init_hook' => sub {
+    my $starman = Test::MockModule->new('Starman::Server');
+    my $built   = 0;
+    $starman->redefine( child_init_hook => sub { $built++ } );
+
+    local $SIG{HUP} = sub { fail('the handler Net::Server installed ran') };
+    my $self = server( connected => 0 );
+    $self->child_init_hook();
+    is( $built, 1, "Starman's hook still runs, so the app is built" );
+
+    $SIG{HUP}->();
+    is( $self->{server}{SigHUPed}, 1, 'a HUP marks the worker HUPed, which done() retires it for' );
+    is( $self->{server}{_HUP},     1, 'and makes accept() return instead of retrying' );
+};
+
+subtest 'accept' => sub {
+    my $net = Test::MockModule->new('Net::Server::PreForkSimple');
+
+    # What Net::Server::accept() does when the HUP lands as it takes a
+    # connection: it has the client, and returns 0 because _HUP is set.
+    $net->redefine( accept => sub { $_[0]{server}{client} = 'a connection'; return 0 } );
+    is( server()->accept(), 1, 'a connection accepted as the HUP came is answered' );
+
+    # And when the HUP interrupts the wait, with nothing taken.
+    $net->redefine( accept => sub { return 0 } );
+    is( server( client => 'the last request' )->accept(), 0, 'a worker that took nothing retires, whatever its last request left behind' );
+
+    $net->redefine( accept => sub { $_[0]{server}{client} = 'a connection'; return 1 } );
+    is( server()->accept(), 1, 'an ordinary accept is passed through' );
+};
+
+subtest 'every connection is answered while the parent is HUPed' => sub {
+    skip_all('RELEASE_TESTING not set') unless $ENV{RELEASE_TESTING};
+
+    require File::Temp;
+    require IO::Socket::UNIX;
+    require Plack::Handler::TPSGI;
+
+    my $dir  = File::Temp::tempdir( CLEANUP => 1 );
+    my $sock = "$dir/s.sock";
+
+    my $server = fork() // die "fork: $!";
+    if ( !$server ) {
+        close(STDERR);
+        Plack::Handler::TPSGI->new( listen => [$sock], workers => 5, pid => "$dir/pid", keepalive => 0 )
+          ->run( sub { [ 200, [ 'Content-Type' => 'text/plain' ], ['ok'] ] } );
+        exit 0;
+    }
+    for ( 1 .. 100 ) { last if -S $sock && -s "$dir/pid"; select( undef, undef, undef, 0.1 ) }
+    ok( -S $sock, 'the server is listening' ) or return;
+    my $parent = do { open( my $fh, '<', "$dir/pid" ) or die $!; local $/; <$fh> };
+    chomp $parent;
+
+    # Four clients, each counting the requests that got no answer.
+    my @clients = map {
+        my $pid = fork() // die "fork: $!";
+        if ( !$pid ) {
+            my $bad = 0;
+            for ( 1 .. 1500 ) {
+                my $c = IO::Socket::UNIX->new( Peer => $sock ) or do { $bad++; next };
+                print $c "GET / HTTP/1.0\r\n\r\n";
+                my $got = do { local $/; <$c> } // '';
+                $bad++ unless $got =~ m{^HTTP/1\.\d 200}a;
+            }
+            exit( $bad > 255 ? 255 : $bad );
+        }
+        $pid
+    } 1 .. 4;
+
+    for ( 1 .. 60 ) { kill( 'HUP', $parent ); select( undef, undef, undef, 0.05 ) }
+
+    my $unanswered = 0;
+    foreach my $pid (@clients) { waitpid( $pid, 0 ); $unanswered += $? >> 8 }
+    is( $unanswered, 0, 'no request of 6000 went unanswered across 60 restarts' );
+
+    kill( 'TERM', $parent );
+    waitpid( $server, 0 );
+};
+
+done_testing();