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