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