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