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     SKIP : {
  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 "Server did not restart, no sense in checking further", 1;
  73         }
  74
  75         my $response = get("http://localhost:$port/");
  76         like( $response, qr/Welcome to the  world of Catalyst/,
  77               'Non-error restart, request OK' );
  78     }
  79 }
  80
  81 # add errors to the file and make sure server does die
  82 DIES_ON_ERROR:
  83 for ( 1 .. 5 ) {
  84     SKIP : {
  85         my $index = rand @files;
  86         open my $pm, '>>', $files[$index]
  87             or die "Unable to open $files[$index] for writing: $!";
  88         print $pm "bleh";
  89         close $pm;
  90
  91         if ( ! look_for_death() ) {
  92             skip "Server restarted, no sense in checking further", 2;
  93         }
  94
  95         copy_test_app();
  96
  97         if ( ! look_for_restart() ) {
  98             skip "Server did not restart, no sense in checking further", 1;
  99         }
 100
 101         my $response = get("http://localhost:$port/");
 102         like( $response, qr/Welcome to the  world of Catalyst/,
 103               'Non-error restart after death, request OK' );
 104     }
 105 }
 106
 107 # multiple restart directories
 108
 109 # we need different options so we have to rebuild most
 110 # of the testing environment
 111
 112 kill 9, $pid or die "Cannot send kill signal to $pid: $!";
 113 close $server or die "Cannot close handle to server process: $!";
 114 wait;
 115
 116 # pick next port because the last one might still be blocked from
 117 # previous server. This might fail if this port is unavailable
 118 # but picking the first one has the same problem so this is acceptable
 119
 120 $port += 1;
 121
 122 copy_test_app();
 123
 124 @files = (
 125   "$appdir/lib/TestApp/Controller/Subdir1/Foo.pm",
 126   "$appdir/lib/TestApp/Controller/Subdir2/Foo.pm",
 127 );
 128
 129 ( $pid, $server ) = start_server($port);
 130
 131 MULTI_DIR_RESTART:
 132 for ( 1 .. 5 ) {
 133     SKIP : {
 134         my $index = rand @files;
 135         open my $pm, '>>', $files[$index]
 136           or die "Unable to open $files[$index] for writing: $!";
 137         print $pm "\n";
 138         close $pm;
 139
 140         if ( ! look_for_restart() ) {
 141             skip "Server did not restart, no sense in checking further", 1;
 142         }
 143
 144         my $response = get("http://localhost:$port/");
 145         like( $response, qr/Welcome to the  world of Catalyst/,
 146               'Non-error restart with multiple watched dirs' );
 147     }
 148 }
 149
 150 kill 9, $pid;
 151 close $server;
 152 wait;
 153
 154 sub copy_test_app {
 155     local $File::Copy::Recursive::RMTrgFil = 1;
 156     dircopy( 't/lib/TestApp', "$appdir/lib/TestApp" );
 157 }
 158
 159 sub start_server {
 160     my $port = shift;
 161
 162     my $server;
 163     my $pid = open3(
 164         undef, $server, undef,
 165         $^X,   "-I$helper_lib",
 166         "$appdir/script/testapp_server.pl", '--port',
 167         $port,                                                     '--restart'
 168     ) or die "Unable to spawn standalone HTTP server: $!";
 169
 170     # switch to non-blocking reads so we can fail gracefully instead
 171     # of just hanging forever
 172     $server->blocking(0);
 173
 174     my $waited = 0;
 175
 176     diag('Waiting for server to start...');
 177     while ( check_port( 'localhost', $port ) != 1 ) {
 178         sleep 1;
 179         $waited++;
 180
 181         if ( $waited >= 10 ) {
 182             die 'Waited 10 seconds for server to start, to no avail';
 183         }
 184     }
 185
 186     return ($pid, $server);
 187 }
 188
 189 sub check_port {
 190     my ( $host, $port ) = @_;
 191
 192     my $remote = IO::Socket::INET->new(
 193         Proto    => "tcp",
 194         PeerAddr => $host,
 195         PeerPort => $port
 196     );
 197     if ($remote) {
 198         close $remote;
 199         return 1;
 200     }
 201     else {
 202         return 0;
 203     }
 204 }
 205
 206 sub look_for_restart {
 207     # give the server time to notice the change and restart
 208     my $count = 0;
 209     my $line;
 210
 211     while ( ( $line || '' ) !~ /Accepting connections/ ) {
 212         $line = $server->getline;
 213         sleep 0.1;
 214         if ( $count++ > 300 ) {
 215             fail "Server restarted";
 216             return 0;
 217         }
 218     };
 219
 220     pass "Server restarted";
 221
 222     return 1;
 223 }
 224
 225 sub look_for_death {
 226     # give the server time to notice the change and restart
 227     my $count = 0;
 228     my $line;
 229
 230     while ( ( $line || '' ) !~ /failed/ ) {
 231         $line = $server->getline;
 232         sleep 0.1;
 233         if ( $count++ > 300 ) {
 234             fail "Server died";
 235             return 0;
 236         }
 237     };
 238
 239     pass "Server died";
 240
 241     return 1;
 242 }