t/optional_http-server-restart.t

   1 # XXX - These tests seem to be somewhat flaky and timing-dependent. I
   2 # have seen them all run to completion, and I've seen them fail
   3 # partway through. If someone can come up with a better way to test
   4 # this stuff that'd be great.
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 BEGIN {
  11     plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
  12 }
  13
  14 use File::Spec::Functions qw(updir catdir);
  15 use Cwd qw(abs_path);
  16 use File::Basename qw(dirname);
  17 use File::Temp qw(tempdir);
  18 use File::Path qw(rmtree);
  19 use LWP::Simple;
  20 use IO::Socket;
  21 use IPC::Open3 qw(open3);
  22 use Time::HiRes qw/sleep/;
  23 use Catalyst::Helper;
  24 use File::Copy::Recursive qw(dircopy);
  25
  26 plan tests => 35;
  27
  28 my $helper_lib = abs_path(catdir(dirname($INC{'Catalyst/Helper.pm'}), updir));
  29
  30 my $tmpdir = tempdir(CLEANUP => 1);
  31 my $appdir = catdir($tmpdir, 'TestApp');
  32
  33 mkdir $appdir;
  34
  35 my $helper = Catalyst::Helper->new(
  36     {
  37         dir => $appdir,
  38         '.newfiles' => 1,
  39     }
  40 );
  41
  42 $helper->mk_app('TestApp');
  43
  44 copy_test_app();
  45
  46 # remove TestApp's tests
  47 rmtree "$appdir/t";
  48
  49 # spawn the standalone HTTP server
  50 my $port = 30000 + int rand( 1 + 10000 );
  51
  52 my ( $pid, $server ) = start_server($port);
  53
  54 # change various files
  55 my @files = (
  56     "$appdir/lib/TestApp.pm",
  57     "$appdir/lib/TestApp/Controller/Foo.pm",
  58     "$appdir/lib/TestApp/Controller/Root.pm",
  59 );
  60
  61 # change some files and make sure the server restarts itself
  62 NON_ERROR_RESTART:
  63 for ( 1 .. 5 ) {
  64     my $index = rand @files;
  65     open my $pm, '>>', $files[$index]
  66       or die "Unable to open $files[$index] for writing: $!";
  67     print $pm "\n";
  68     close $pm;
  69
  70     if ( ! look_for_restart() ) {
  71     SKIP:
  72         {
  73             skip "Server did not restart, no sense in checking further", 1;
  74         }
  75         next NON_ERROR_RESTART;
  76     }
  77
  78     my $response = get("http://localhost:$port/");
  79     like( $response, qr/Welcome to the  world of Catalyst/,
  80           'Non-error restart, request OK' );
  81 }
  82
  83 # add errors to the file and make sure server does die
  84 DIES_ON_ERROR:
  85 for ( 1 .. 5 ) {
  86     my $index = rand @files;
  87     open my $pm, '>>', $files[$index]
  88       or die "Unable to open $files[$index] for writing: $!";
  89     print $pm "bleh";
  90     close $pm;
  91
  92     if ( ! look_for_death() ) {
  93     SKIP:
  94         {
  95             skip "Server restarted, no sense in checking further", 2;
  96         }
  97         next DIES_ON_ERROR;
  98     }
  99     copy_test_app();
 100
 101     if ( ! look_for_restart() ) {
 102     SKIP:
 103         {
 104             skip "Server did not restart, no sense in checking further", 1;
 105         }
 106         next DIES_ON_ERROR;
 107     }
 108
 109     my $response = get("http://localhost:$port/");
 110     like( $response, qr/Welcome to the  world of Catalyst/,
 111           'Non-error restart after death, request OK' );
 112 }
 113
 114 # multiple restart directories
 115
 116 # we need different options so we have to rebuild most
 117 # of the testing environment
 118
 119 kill 9, $pid or die "Cannot send kill signal to $pid: $!";
 120 close $server or die "Cannot close handle to server process: $!";
 121 wait;
 122
 123 # pick next port because the last one might still be blocked from
 124 # previous server. This might fail if this port is unavailable
 125 # but picking the first one has the same problem so this is acceptable
 126
 127 $port += 1;
 128
 129 copy_test_app();
 130
 131 @files = (
 132   "$appdir/lib/TestApp/Controller/Subdir1/Foo.pm",
 133   "$appdir/lib/TestApp/Controller/Subdir2/Foo.pm",
 134 );
 135
 136 ( $pid, $server ) = start_server($port);
 137
 138 MULTI_DIR_RESTART:
 139 for ( 1 .. 5 ) {
 140     SKIP : {
 141         my $index = rand @files;
 142         open my $pm, '>>', $files[$index]
 143           or die "Unable to open $files[$index] for writing: $!";
 144         print $pm "\n";
 145         close $pm;
 146
 147         if ( ! look_for_restart() ) {
 148             skip "Server did not restart, no sense in checking further", 1;
 149         }
 150
 151         my $response = get("http://localhost:$port/");
 152         like( $response, qr/Welcome to the  world of Catalyst/,
 153               'Non-error restart with multiple watched dirs' );
 154     }
 155 }
 156
 157 kill 9, $pid;
 158 close $server;
 159 wait;
 160
 161 sub copy_test_app {
 162     local $File::Copy::Recursive::RMTrgFil = 1;
 163     dircopy( 't/lib/TestApp', "$appdir/lib/TestApp" );
 164 }
 165
 166 sub start_server {
 167     my $port = shift;
 168
 169     my $server;
 170     my $pid = open3(
 171         undef, $server, undef,
 172         $^X,   "-I$helper_lib",
 173         "$appdir/script/testapp_server.pl", '--port',
 174         $port,                                                     '--restart'
 175     ) or die "Unable to spawn standalone HTTP server: $!";
 176
 177     # switch to non-blocking reads so we can fail gracefully instead
 178     # of just hanging forever
 179     $server->blocking(0);
 180
 181     my $waited = 0;
 182
 183     diag('Waiting for server to start...');
 184     while ( check_port( 'localhost', $port ) != 1 ) {
 185         sleep 1;
 186         $waited++;
 187
 188         if ( $waited >= 10 ) {
 189             BAIL_OUT('Waited 10 seconds for server to start, to no avail');
 190         }
 191     }
 192
 193     return ($pid, $server);
 194 }
 195
 196 sub check_port {
 197     my ( $host, $port ) = @_;
 198
 199     my $remote = IO::Socket::INET->new(
 200         Proto    => "tcp",
 201         PeerAddr => $host,
 202         PeerPort => $port
 203     );
 204     if ($remote) {
 205         close $remote;
 206         return 1;
 207     }
 208     else {
 209         return 0;
 210     }
 211 }
 212
 213 sub look_for_restart {
 214     # give the server time to notice the change and restart
 215     my $count = 0;
 216     my $line;
 217
 218     while ( ( $line || '' ) !~ /can connect/ ) {
 219         $line = $server->getline;
 220         sleep 0.1;
 221         if ( $count++ > 300 ) {
 222             fail "Server restarted";
 223             return 0;
 224         }
 225     };
 226
 227     pass "Server restarted";
 228
 229     return 1;
 230 }
 231
 232 sub look_for_death {
 233     # give the server time to notice the change and restart
 234     my $count = 0;
 235     my $line;
 236
 237     while ( ( $line || '' ) !~ /failed/ ) {
 238         $line = $server->getline;
 239         sleep 0.1;
 240         if ( $count++ > 300 ) {
 241             fail "Server died";
 242             return 0;
 243         }
 244     };
 245
 246     pass "Server died";
 247
 248     return 1;
 249 }