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 "$tmpdir/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     "$tmpdir/TestApp/lib/TestApp.pm",
  58     "$tmpdir/TestApp/lib/TestApp/Controller/Foo.pm",
  59     "$tmpdir/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   "$tmpdir/TestApp/lib/TestApp/Controller/Subdir1/Foo.pm",
 134   "$tmpdir/TestApp/lib/TestApp/Controller/Subdir2/Foo.pm",
 135 );
 136
 137 my $app_root = "$tmpdir/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 $tmpdir if -d $tmpdir;
 170
 171 sub copy_test_app {
 172     { no warnings 'once'; $File::Copy::Recursive::RMTrgFil = 1; }
 173     File::Copy::Recursive::dircopy( 't/lib/TestApp', "$tmpdir/TestApp/lib/TestApp" );
 174 }
 175
 176 sub start_server {
 177     my $port = shift;
 178
 179     my $server;
 180     my $pid = open3(
 181         undef, $server, undef,
 182         $^X,   "-I$FindBin::Bin/../lib",
 183         "$tmpdir/TestApp/script/testapp_server.pl", '--port',
 184         $port,                                                     '--restart'
 185     ) or die "Unable to spawn standalone HTTP server: $!";
 186
 187     # switch to non-blocking reads so we can fail gracefully instead
 188     # of just hanging forever
 189     $server->blocking(0);
 190
 191     my $waited = 0;
 192
 193     diag('Waiting for server to start...');
 194     while ( check_port( 'localhost', $port ) != 1 ) {
 195         sleep 1;
 196         $waited++;
 197
 198         if ( $waited >= 10 ) {
 199             BAIL_OUT('Waited 10 seconds for server to start, to no avail');
 200         }
 201     }
 202
 203     return ($pid, $server);
 204 }
 205
 206 sub check_port {
 207     my ( $host, $port ) = @_;
 208
 209     my $remote = IO::Socket::INET->new(
 210         Proto    => "tcp",
 211         PeerAddr => $host,
 212         PeerPort => $port
 213     );
 214     if ($remote) {
 215         close $remote;
 216         return 1;
 217     }
 218     else {
 219         return 0;
 220     }
 221 }
 222
 223 sub look_for_restart {
 224     # give the server time to notice the change and restart
 225     my $count = 0;
 226     my $line;
 227
 228     while ( ( $line || '' ) !~ /can connect/ ) {
 229         $line = $server->getline;
 230         sleep 0.1;
 231         if ( $count++ > 300 ) {
 232             fail "Server restarted";
 233             return 0;
 234         }
 235     };
 236
 237     pass "Server restarted";
 238
 239     return 1;
 240 }
 241
 242 sub look_for_death {
 243     # give the server time to notice the change and restart
 244     my $count = 0;
 245     my $line;
 246
 247     while ( ( $line || '' ) !~ /failed/ ) {
 248         $line = $server->getline;
 249         sleep 0.1;
 250         if ( $count++ > 300 ) {
 251             fail "Server died";
 252             return 0;
 253         }
 254     };
 255
 256     pass "Server died";
 257
 258     return 1;
 259 }