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