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     our $GOT_HUP;
 114     local $GOT_HUP = 0;
 115
 116     local $SIG{HUP} = sub { $GOT_HUP = 1; };
 117     local $SIG{CHLD} = 'IGNORE';
 118
 119     my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' };
 120
 121     # Handle requests
 122
 123     # Setup socket
 124     $host = $host ? inet_aton($host) : INADDR_ANY;
 125     socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
 126       || die "Couldn't assign TCP socket: $!";
 127     setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
 128       || die "Couldn't set TCP socket options: $!";
 129     bind( HTTPDaemon, sockaddr_in( $port, $host ) )
 130       || die "Couldn't bind socket to $port on $host: $!";
 131     listen( HTTPDaemon, SOMAXCONN )
 132       || die "Couldn't listen to socket on $port on $host: $!";
 133     my $url = 'http://';
 134     if ( $host eq INADDR_ANY ) {
 135         require Sys::Hostname;
 136         $url .= lc Sys::Hostname::hostname();
 137     }
 138     else {
 139         $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
 140     }
 141     $url .= ":$port";
 142     print "You can connect to your server at $url\n";
 143     my $pid = undef;
 144     while ( accept( Remote, HTTPDaemon ) ) {
 145
 146         # Fork
 147         if ( $options->{fork} ) { next if $pid = fork }
 148
 149         close HTTPDaemon if defined $pid;
 150
 151         # Ignore broken pipes as an HTTP server should
 152         local $SIG{PIPE} = sub { close Remote };
 153         local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
 154
 155         local *STDIN  = \*Remote;
 156         local *STDOUT = \*Remote;
 157         select STDOUT;
 158
 159         # Request data
 160         my $remote_sockaddr = getpeername( \*Remote );
 161         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
 162         my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
 163         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 164         my $local_sockaddr = getsockname( \*Remote );
 165         my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
 166         my $localname = gethostbyaddr( $localiaddr, AF_INET )
 167           || "localhost";
 168         my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
 169
 170         STDIN->blocking(1);
 171
 172         # Parse request line
 173         my $line = $self->_get_line( \*STDIN );
 174         next
 175           unless my ( $method, $uri, $protocol ) =
 176           $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
 177
 178         # We better be careful and just use 1.0
 179         $protocol = '1.0';
 180
 181         my ( $path, $query_string ) = split /\?/, $uri, 2;
 182
 183         # Initialize CGI environment
 184         local %ENV = (
 185             PATH_INFO      => $path         || '',
 186             QUERY_STRING   => $query_string || '',
 187             REMOTE_ADDR    => $peeraddr,
 188             REMOTE_HOST    => $peername,
 189             REQUEST_METHOD => $method       || '',
 190             SERVER_NAME    => $localname,
 191             SERVER_PORT    => $port,
 192             SERVER_PROTOCOL => "HTTP/$protocol",
 193             %ENV,
 194         );
 195
 196         # Parse headers
 197         if ( $protocol >= 1 ) {
 198             while (1) {
 199                 my $line = $self->_get_line( \*STDIN );
 200                 last if $line eq '';
 201                 next
 202                   unless my ( $name, $value ) =
 203                   $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;
 204
 205                 $name = uc $name;
 206                 $name = 'COOKIE' if $name eq 'COOKIES';
 207                 $name =~ tr/-/_/;
 208                 $name = 'HTTP_' . $name
 209                   unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
 210                 if ( exists $ENV{$name} ) {
 211                     $ENV{$name} .= "; $value";
 212                 }
 213                 else {
 214                     $ENV{$name} = $value;
 215                 }
 216             }
 217         }
 218         unless ( uc($method) eq 'KILL' ) {
 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                 $GOT_HUP = 1;
 231                 last;
 232             }
 233         }
 234         exit if defined $pid;
 235     }
 236     continue {
 237         close Remote;
 238     }
 239     close HTTPDaemon;
 240
 241     if ($GOT_HUP) {
 242         $SIG{CHLD} = 'DEFAULT';
 243         wait;
 244         exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } );
 245     }
 246 }
 247
 248 sub _get_line {
 249     my ( $self, $handle ) = @_;
 250
 251     my $line = '';
 252
 253     while ( sysread( $handle, my $byte, 1 ) ) {
 254         last if $byte eq "\012";    # eol
 255         $line .= $byte;
 256     }
 257
 258     1 while $line =~ s/\s\z//;
 259
 260     return $line;
 261 }
 262
 263 sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
 264
 265 =back
 266
 267 =head1 SEE ALSO
 268
 269 L<Catalyst>, L<Catalyst::Engine>.
 270
 271 =head1 AUTHORS
 272
 273 Sebastian Riedel, <sri@cpan.org>
 274
 275 Dan Kubb, <dan.kubb-cpan@onautopilot.com>
 276
 277 =head1 THANKS
 278
 279 Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
 280
 281 =head1 COPYRIGHT
 282
 283 This program is free software, you can redistribute it and/or modify it under
 284 the same terms as Perl itself.
 285
 286 =cut
 287
 288 1;