t/optional_http-server-restart.t

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