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