Merge pull request #19 from Troglodyne-Internet-Widgets/retire-broken-workers

Retire a worker whose router would not load, and say so in a page

lib/TPSGI.pm

@@ -43,7 +43,7 @@ use Config::Simple;
 use TPSGI::Startup;
 
 # We have a DEBUG var which is plus ultra for extra sensitive stuff beyond just passing verbose
-my $debug = $ENV{TPSGI_DEBUG};
+our $debug = $ENV{TPSGI_DEBUG};
 
 #1MB chunks
 our $CHUNK_SEP  = 'perlfsSep666YOLO42069';
@@ -608,6 +608,18 @@ the same options, so it lands in the same places a request's own errors do.  If
 building the log is what failed -- a logger that will not load -- psgi.errors
 is all there is, and the answer is still a 500 rather than a second exception.
 
+The answer is a page of our own, not the router's error page: the router is
+what failed.  With TPSGI_DEBUG set it carries the error itself, trace and all,
+for the same reason _generic() adds one; without, it says nothing a visitor
+could use to map the installation.
+
+The worker retires once it has answered, on a server that offers
+psgix.harakiri, which Starman does.  A router that died while it compiled
+leaves its file in %INC as a failure, and every later require of it in this
+process says only "Attempt to reload ... aborted" -- so a load that failed
+once, to a race or a lock, would otherwise fail for every request the worker
+ever serves.  A fresh worker tries again from nothing.
+
 =cut
 
 sub cannot_start {
@@ -616,7 +628,18 @@ sub cannot_start {
     $env->{'psgi.errors'}->print($error) if ref $env eq 'HASH' && $env->{'psgi.errors'};
     eval { bless( { %options, ip => '0.0.0.0' }, __PACKAGE__ )->ERROR("Could not start: $error"); 1 };
 
-    return [ 500, [ $ct => $content_types{text} ], ['Internal Server Error'] ];
+    $env->{'psgix.harakiri.commit'} = 1 if ref $env eq 'HASH' && $env->{'psgix.harakiri'};
+
+    my $detail = '';
+    if ($debug) {
+        ( my $escaped = $error ) =~ s/([&<>"])/'&#' . ord($1) . ';'/ge;
+        $detail = "<pre>$escaped</pre>";
+    }
+
+    my $page = "<!doctype html><html><head><meta charset=\"utf-8\"><title>Internal Server Error</title></head>"
+      . "<body><h1>Internal Server Error</h1>$detail</body></html>";
+
+    return [ 500, [ $ct => $content_types{html} ], [$page] ];
 }
 
 my %etags;

t/TPSGI.t

@@ -73,6 +73,32 @@ subtest 'cannot_start' => sub {
     ok( lives { TPSGI::cannot_start( "no env\n", undef, %options ) }, 'a missing env is not a second failure' ) or note $@;
 };
 
+subtest 'cannot_start retires the worker' => sub {
+    my ( $env ) = fake_env();
+    $env->{'psgix.harakiri'} = 1;
+    TPSGI::cannot_start( "Could not load Bogus.pm!\n", $env, %options );
+    ok( $env->{'psgix.harakiri.commit'}, 'a server that can retire the worker is told to' );
+
+    ( $env ) = fake_env();
+    TPSGI::cannot_start( "Could not load Bogus.pm!\n", $env, %options );
+    ok( !exists $env->{'psgix.harakiri.commit'}, 'a server that cannot is not asked to' );
+};
+
+subtest 'cannot_start answers with a page' => sub {
+    my $error = "Could not load Bogus.pm!\nCan't locate <Bogus/Dep.pm> in \@INC & \"elsewhere\"\n";
+
+    my $res  = TPSGI::cannot_start( $error, ( fake_env() )[0], %options );
+    my %head = @{ $res->[1] };
+    is( $head{'Content-type'}, 'text/html', 'in HTML' );
+    like( $res->[2][0], qr/<h1>Internal Server Error<\/h1>/, 'saying what happened' );
+    unlike( $res->[2][0], qr/Bogus/, 'and, without TPSGI_DEBUG, not why' );
+
+    local $TPSGI::debug = 1;
+    $res = TPSGI::cannot_start( $error, ( fake_env() )[0], %options );
+    like( $res->[2][0], qr/Can't locate &#60;Bogus\/Dep\.pm&#62; in \@INC &#38; &#34;elsewhere&#34;/, 'with TPSGI_DEBUG, the error, escaped' );
+    unlike( $res->[2][0], qr/<Bogus/, 'none of it read as markup' );
+};
+
 subtest 'app, when the request dies' => sub {
     local @Test::Logger::Capture::lines;
     my ( $env, $written ) = fake_env();