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