lib/Catalyst/Engine/HTTP.pm

   1 package Catalyst::Engine::HTTP;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI';
   5 use Errno 'EWOULDBLOCK';
   6 use FindBin;
   7 use File::Find;
   8 use File::Spec;
   9 use HTTP::Status;
  10 use NEXT;
  11 use Socket;
  12
  13 =head1 NAME
  14
  15 Catalyst::Engine::HTTP - Catalyst HTTP Engine
  16
  17 =head1 SYNOPSIS
  18
  19 A script using the Catalyst::Engine::HTTP module might look like:
  20
  21     #!/usr/bin/perl -w
  22
  23     BEGIN {  $ENV{CATALYST_ENGINE} = 'HTTP' }
  24
  25     use strict;
  26     use lib '/path/to/MyApp/lib';
  27     use MyApp;
  28
  29     MyApp->run;
  30
  31 =head1 DESCRIPTION
  32
  33 This is the Catalyst engine specialized for development and testing.
  34
  35 =head1 METHODS
  36
  37 =over 4
  38
  39 =item $self->finalize_headers($c)
  40
  41 =cut
  42
  43 sub finalize_headers {
  44     my ( $self, $c ) = @_;
  45     my $protocol = $c->request->protocol;
  46     my $status   = $c->response->status;
  47     my $message  = status_message($status);
  48     print "$protocol $status $message\015\012";
  49     $c->response->headers->date(time);
  50     $self->NEXT::finalize_headers($c);
  51 }
  52
  53 =item $self->finalize_read($c)
  54
  55 =cut
  56
  57 sub finalize_read {
  58     my ( $self, $c ) = @_;
  59
  60     # Never ever remove this, it would result in random length output
  61     # streams if STDIN eq STDOUT (like in the HTTP engine)
  62     *STDIN->blocking(1);
  63
  64     return $self->NEXT::finalize_read($c);
  65 }
  66
  67 =item $self->prepare_read($c)
  68
  69 =cut
  70
  71 sub prepare_read {
  72     my ( $self, $c ) = @_;
  73
  74     # Set the input handle to non-blocking
  75     *STDIN->blocking(0);
  76
  77     return $self->NEXT::prepare_read($c);
  78 }
  79
  80 =item $self->read_chunk($c, $buffer, $length)
  81
  82 =cut
  83
  84 sub read_chunk {
  85     my $self = shift;
  86     my $c    = shift;
  87
  88     # support for non-blocking IO
  89     my $rin = '';
  90     vec( $rin, *STDIN->fileno, 1 ) = 1;
  91
  92   READ:
  93     {
  94         select( $rin, undef, undef, undef );
  95         my $rc = *STDIN->sysread(@_);
  96         if ( defined $rc ) {
  97             return $rc;
  98         }
  99         else {
 100             next READ if $! == EWOULDBLOCK;
 101             return;
 102         }
 103     }
 104 }
 105
 106 =item run
 107
 108 =cut
 109
 110 # A very very simple HTTP server that initializes a CGI environment
 111 sub run {
 112     my ( $self, $class, $port, $host, $options ) = @_;
 113
 114     $options ||= {};
 115
 116     our $GOT_HUP;
 117     local $GOT_HUP = 0;
 118
 119     local $SIG{HUP} = sub { $GOT_HUP = 1; };
 120     local $SIG{CHLD} = 'IGNORE';
 121
 122     # Setup restarter
 123     my $restarter;
 124     if ( $options->{restart} ) {
 125         my $parent = $$;
 126         unless ( $restarter = fork ) {
 127
 128             # Prepare
 129             close STDIN;
 130             close STDOUT;
 131
 132             # Index parent directory
 133             my $dir = File::Spec->catdir( $FindBin::Bin, '..' );
 134
 135             my $regex = $options->{restart_regex};
 136             my $one   = _index( $dir, $regex );
 137           RESTART: while (1) {
 138                 sleep $options->{restart_delay};
 139                 my $two     = _index( $dir,         $regex );
 140                 my $changes = _compare_index( $one, $two );
 141                 if (@$changes) {
 142                     $one = $two;
 143
 144                     # Test modified pm's
 145                     for my $file (@$changes) {
 146                         next unless $file =~ /\.pm$/;
 147                         if ( my $error = _test($file) ) {
 148                             print STDERR
 149                               qq/File "$file" modified, not restarting\n\n/;
 150                             print STDERR '*' x 80, "\n";
 151                             print STDERR $error;
 152                             print STDERR '*' x 80, "\n";
 153                             next RESTART;
 154                         }
 155                     }
 156
 157                     # Restart
 158                     my $files = join ', ', @$changes;
 159                     print STDERR qq/File(s) "$files" modified, restarting\n\n/;
 160                     kill( 1, $parent );
 161                     exit;
 162                 }
 163             }
 164         }
 165     }
 166
 167     # Handle requests
 168
 169     # Setup socket
 170     $host = $host ? inet_aton($host) : INADDR_ANY;
 171     socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
 172         || die "Couldn't assign TCP socket: $!";
 173     setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
 174         || die "Couldn't set TCP socket options: $!";
 175     bind( HTTPDaemon, sockaddr_in( $port, $host ) )
 176         || die "Couldn't bind socket to $port on $host: $!";
 177     listen( HTTPDaemon, SOMAXCONN )
 178         || die "Couldn't listen to socket on $port on $host: $!";
 179     my $url = 'http://';
 180     if ( $host eq INADDR_ANY ) {
 181         require Sys::Hostname;
 182         $url .= lc Sys::Hostname::hostname();
 183     }
 184     else {
 185         $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
 186     }
 187     $url .= ":$port";
 188     print "You can connect to your server at $url\n";
 189     my $pid = undef;
 190     while ( accept( Remote, HTTPDaemon ) ) {
 191
 192         # Fork
 193         if ( $options->{fork} ) { next if $pid = fork }
 194
 195         close HTTPDaemon if defined $pid;
 196
 197         # Ignore broken pipes as an HTTP server should
 198         local $SIG{PIPE} = sub { close Remote };
 199         local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
 200
 201         local *STDIN  = \*Remote;
 202         local *STDOUT = \*Remote;
 203         select STDOUT;
 204
 205         # Request data
 206         my $remote_sockaddr = getpeername( \*Remote );
 207         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
 208         my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
 209         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 210         my $local_sockaddr = getsockname( \*Remote );
 211         my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
 212         my $localname = gethostbyaddr( $localiaddr, AF_INET )
 213           || "localhost";
 214         my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
 215
 216         STDIN->blocking(1);
 217
 218         # Parse request line
 219         my $line = $self->_get_line( \*STDIN );
 220         next
 221           unless my ( $method, $uri, $protocol ) =
 222           $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
 223
 224         # We better be careful and just use 1.0
 225         $protocol = '1.0';
 226
 227         my ( $path, $query_string ) = split /\?/, $uri, 2;
 228
 229         # Initialize CGI environment
 230         local %ENV = (
 231             PATH_INFO      => $path         || '',
 232             QUERY_STRING   => $query_string || '',
 233             REMOTE_ADDR    => $peeraddr,
 234             REMOTE_HOST    => $peername,
 235             REQUEST_METHOD => $method       || '',
 236             SERVER_NAME    => $localname,
 237             SERVER_PORT    => $port,
 238             SERVER_PROTOCOL => "HTTP/$protocol",
 239             %ENV,
 240         );
 241
 242         # Parse headers
 243         if ( $protocol >= 1 ) {
 244             while (1) {
 245                 my $line = $self->_get_line( \*STDIN );
 246                 last if $line eq '';
 247                 next
 248                   unless my ( $name, $value ) =
 249                   $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;
 250
 251                 $name = uc $name;
 252                 $name = 'COOKIE' if $name eq 'COOKIES';
 253                 $name =~ tr/-/_/;
 254                 $name = 'HTTP_' . $name
 255                   unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
 256                 if ( exists $ENV{$name} ) {
 257                     $ENV{$name} .= "; $value";
 258                 }
 259                 else {
 260                     $ENV{$name} = $value;
 261                 }
 262             }
 263         }
 264
 265         # Pass flow control to Catalyst
 266         $class->handle_request;
 267         exit if defined $pid;
 268     }
 269     continue {
 270         close Remote;
 271     }
 272     close HTTPDaemon;
 273
 274     if ($GOT_HUP) {
 275         $SIG{CHLD} = 'DEFAULT';
 276         wait;
 277         exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @{ $options->{argv} } );
 278     }
 279 }
 280
 281 sub _compare_index {
 282     my ( $one, $two ) = @_;
 283     my %clone = %$two;
 284     my @changes;
 285     while ( my ( $key, $val ) = each %$one ) {
 286         if ( !$clone{$key} || ( $clone{$key} ne $val ) ) {
 287             push @changes, $key;
 288         }
 289         delete $clone{$key};
 290     }
 291     for my $key ( keys %clone ) { push @changes, $key }
 292     return \@changes;
 293 }
 294
 295 sub _get_line {
 296     my ( $self, $handle ) = @_;
 297
 298     my $line = '';
 299
 300     while ( sysread( $handle, my $byte, 1 ) ) {
 301         last if $byte eq "\012";    # eol
 302         $line .= $byte;
 303     }
 304
 305     1 while $line =~ s/\s\z//;
 306
 307     return $line;
 308 }
 309
 310 sub _index {
 311     my ( $dir, $regex ) = @_;
 312     my %index;
 313     finddepth(
 314         {
 315             wanted => sub {
 316                 my $file = File::Spec->rel2abs($File::Find::name);
 317                 return unless $file =~ /$regex/;
 318                 return unless -f $file;
 319                 my $time = ( stat $file )[9];
 320                 $index{$file} = $time;
 321             },
 322             no_chdir => 1
 323         },
 324         $dir
 325     );
 326     return \%index;
 327 }
 328
 329 sub _test {
 330     my $file = shift;
 331     delete $INC{$file};
 332     local $SIG{__WARN__} = sub { };
 333     open my $olderr, '>&STDERR';
 334     open STDERR, '>', File::Spec->devnull;
 335     eval "require '$file'";
 336     open STDERR, '>&', $olderr;
 337     return $@ if $@;
 338     return 0;
 339 }
 340
 341 =back
 342
 343 =head1 SEE ALSO
 344
 345 L<Catalyst>, L<Catalyst::Engine>.
 346
 347 =head1 AUTHORS
 348
 349 Sebastian Riedel, <sri@cpan.org>
 350
 351 Dan Kubb, <dan.kubb-cpan@onautopilot.com>
 352
 353 =head1 THANKS
 354
 355 Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
 356
 357 =head1 COPYRIGHT
 358
 359 This program is free software, you can redistribute it and/or modify it under
 360 the same terms as Perl itself.
 361
 362 =cut
 363
 364 1;