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