[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine / HTTP.pm

package Catalyst::Engine::HTTP;

use strict;
use base 'Catalyst::Engine::CGI';
use Errno 'EWOULDBLOCK';
use FindBin;
use File::Find;
use File::Spec;
use HTTP::Status;
use NEXT;
use Socket;

=head1 NAME

Catalyst::Engine::HTTP - Catalyst HTTP Engine

=head1 SYNOPSIS

A script using the Catalyst::Engine::HTTP module might look like:

    #!/usr/bin/perl -w

    BEGIN {  $ENV{CATALYST_ENGINE} = 'HTTP' }

    use strict;
    use lib '/path/to/MyApp/lib';
    use MyApp;

    MyApp->run;

=head1 DESCRIPTION

This is the Catalyst engine specialized for development and testing.

=head1 METHODS

=over 4

=item $self->finalize_headers($c)

=cut

sub finalize_headers {
    my ( $self, $c ) = @_;
    my $protocol = $c->request->protocol;
    my $status   = $c->response->status;
    my $message  = status_message($status);
    print "$protocol $status $message\015\012";
    $c->response->headers->date(time);
    $self->NEXT::finalize_headers($c);
}

=item $self->finalize_read($c)

=cut

sub finalize_read {
    my ( $self, $c ) = @_;

    # Never ever remove this, it would result in random length output
    # streams if STDIN eq STDOUT (like in the HTTP engine)
    *STDIN->blocking(1);

    return $self->NEXT::finalize_read($c);
}

=item $self->prepare_read($c)

=cut

sub prepare_read {
    my ( $self, $c ) = @_;

    # Set the input handle to non-blocking
    *STDIN->blocking(0);

    return $self->NEXT::prepare_read($c);
}

=item $self->read_chunk($c, $buffer, $length)

=cut

sub read_chunk {
    my $self = shift;
    my $c    = shift;

    # support for non-blocking IO
    my $rin = '';
    vec( $rin, *STDIN->fileno, 1 ) = 1;

  READ:
    {
        select( $rin, undef, undef, undef );
        my $rc = *STDIN->sysread(@_);
        if ( defined $rc ) {
            return $rc;
        }
        else {
            next READ if $! == EWOULDBLOCK;
            return;
        }
    }
}

=item run

=cut

# A very very simple HTTP server that initializes a CGI environment
sub run {
    my ( $self, $class, $port, $host, $options ) = @_;

    $options ||= {};

    # Setup restarter
    my $restarter;
    if ( $options->{restart} ) {
        my $parent = $$;
        unless ( $restarter = fork ) {

            # Prepare
            close STDIN;
            close STDOUT;

            # Index parent directory
            my $dir = File::Spec->catdir( $FindBin::Bin, '..' );

            my $regex = $options->{restart_regex};
            my $one   = _index( $dir, $regex );
          RESTART: while (1) {
                sleep $options->{restart_delay} || 1;
                
                # check if our parent has died
                exit if ( getppid == 1 );
                
                my $two     = _index( $dir,         $regex );
                my $changes = _compare_index( $one, $two );
                if (@$changes) {
                    $one = $two;

                    # Test modified pm's
                    for my $file (@$changes) {
                        next unless $file =~ /\.pm$/;
                        if ( my $error = _test($file) ) {
                            print STDERR
                              qq/File "$file" modified, not restarting\n\n/;
                            print STDERR '*' x 80, "\n";
                            print STDERR $error;
                            print STDERR '*' x 80, "\n";
                            next RESTART;
                        }
                    }

                    # Restart
                    my $files = join ', ', @$changes;
                    print STDERR qq/File(s) "$files" modified, restarting\n\n/;
                    kill( 1, $parent );
                    exit;
                }
            }
        }
    }
    
    our $GOT_HUP;
    local $GOT_HUP = 0;
    
    local $SIG{HUP} = sub { $GOT_HUP = 1; };
    local $SIG{CHLD} = 'IGNORE';

    # Handle requests

    # Setup socket
    $host = $host ? inet_aton($host) : INADDR_ANY;
    socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
        || die "Couldn't assign TCP socket: $!";
    setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
        || die "Couldn't set TCP socket options: $!";
    bind( HTTPDaemon, sockaddr_in( $port, $host ) )
        || die "Couldn't bind socket to $port on $host: $!";
    listen( HTTPDaemon, SOMAXCONN )
	|| die "Couldn't listen to socket on $port on $host: $!";
    my $url = 'http://';
    if ( $host eq INADDR_ANY ) {
        require Sys::Hostname;
        $url .= lc Sys::Hostname::hostname();
    }
    else {
        $url .= gethostbyaddr( $host, AF_INET ) || inet_ntoa($host);
    }
    $url .= ":$port";
    print "You can connect to your server at $url\n";
    my $pid = undef;
    while ( accept( Remote, HTTPDaemon ) ) {

        # Fork
        if ( $options->{fork} ) { next if $pid = fork }

        close HTTPDaemon if defined $pid;

        # Ignore broken pipes as an HTTP server should
        local $SIG{PIPE} = sub { close Remote };
        local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );

        local *STDIN  = \*Remote;
        local *STDOUT = \*Remote;
        select STDOUT;

        # Request data
        my $remote_sockaddr = getpeername( \*Remote );
        my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
        my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
        my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
        my $local_sockaddr = getsockname( \*Remote );
        my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
        my $localname = gethostbyaddr( $localiaddr, AF_INET )
          || "localhost";
        my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";

        STDIN->blocking(1);

        # Parse request line
        my $line = $self->_get_line( \*STDIN );
        next
          unless my ( $method, $uri, $protocol ) =
          $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;

        # We better be careful and just use 1.0
        $protocol = '1.0';

        my ( $path, $query_string ) = split /\?/, $uri, 2;

        # Initialize CGI environment
        local %ENV = (
            PATH_INFO      => $path         || '',
            QUERY_STRING   => $query_string || '',
            REMOTE_ADDR    => $peeraddr,
            REMOTE_HOST    => $peername,
            REQUEST_METHOD => $method       || '',
            SERVER_NAME    => $localname,
            SERVER_PORT    => $port,
            SERVER_PROTOCOL => "HTTP/$protocol",
            %ENV,
        );

        # Parse headers
        if ( $protocol >= 1 ) {
            while (1) {
                my $line = $self->_get_line( \*STDIN );
                last if $line eq '';
                next
                  unless my ( $name, $value ) =
                  $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;

                $name = uc $name;
                $name = 'COOKIE' if $name eq 'COOKIES';
                $name =~ tr/-/_/;
                $name = 'HTTP_' . $name
                  unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
                if ( exists $ENV{$name} ) {
                    $ENV{$name} .= "; $value";
                }
                else {
                    $ENV{$name} = $value;
                }
            }
        }

        # Pass flow control to Catalyst
        $class->handle_request;
        exit if defined $pid;
    }
    continue {
        close Remote;
    }
    close HTTPDaemon;

    if ($GOT_HUP) {
        $SIG{CHLD} = 'DEFAULT';
        wait;
        exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @{ $options->{argv} } );
    }
}

sub _compare_index {
    my ( $one, $two ) = @_;
    my %clone = %$two;
    my @changes;
    while ( my ( $key, $val ) = each %$one ) {
        if ( !$clone{$key} || ( $clone{$key} ne $val ) ) {
            push @changes, $key;
        }
        delete $clone{$key};
    }
    for my $key ( keys %clone ) { push @changes, $key }
    return \@changes;
}

sub _get_line {
    my ( $self, $handle ) = @_;

    my $line = '';

    while ( sysread( $handle, my $byte, 1 ) ) {
        last if $byte eq "\012";    # eol
        $line .= $byte;
    }

    1 while $line =~ s/\s\z//;

    return $line;
}

sub _index {
    my ( $dir, $regex ) = @_;
    my %index;
    finddepth(
        {
            wanted => sub {
                my $file = File::Spec->rel2abs($File::Find::name);
                return unless $file =~ /$regex/;
                return unless -f $file;
                my $time = ( stat $file )[9];
                $index{$file} = $time;
            },
            no_chdir => 1
        },
        $dir
    );
    return \%index;
}

sub _test {
    my $file = shift;
    delete $INC{$file};
    local $SIG{__WARN__} = sub { };
    open my $olderr, '>&STDERR';
    open STDERR, '>', File::Spec->devnull;
    eval "require '$file'";
    open STDERR, '>&', $olderr;
    return $@ if $@;
    return 0;
}

=back

=head1 SEE ALSO

L<Catalyst>, L<Catalyst::Engine>.

=head1 AUTHORS

Sebastian Riedel, <sri@cpan.org>

Dan Kubb, <dan.kubb-cpan@onautopilot.com>

=head1 THANKS

Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
Commit	Line	Data
ca61af20	1	package Catalyst::Engine::HTTP;
45374ac6	2
45374ac6	3	use strict;
fbcc39ad	4	use base 'Catalyst::Engine::CGI';
fbcc39ad	5	use Errno 'EWOULDBLOCK';
37553dc8	6	use FindBin;
	7	use File::Find;
	8	use File::Spec;
fbcc39ad	9	use HTTP::Status;
	10	use NEXT;
	11	use Socket;
45374ac6	12
	13	=head1 NAME
	14
ca61af20	15	Catalyst::Engine::HTTP - Catalyst HTTP Engine
45374ac6	16
	17	=head1 SYNOPSIS
	18
ca61af20	19	A script using the Catalyst::Engine::HTTP module might look like:
45374ac6	20
	21	#!/usr/bin/perl -w
	22
ca61af20	23	BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' }
45374ac6	24
	25	use strict;
	26	use lib '/path/to/MyApp/lib';
	27	use MyApp;
	28
	29	MyApp->run;
	30
	31	=head1 DESCRIPTION
	32
	33	This is the Catalyst engine specialized for development and testing.
	34
fbcc39ad	35	=head1 METHODS
	36
	37	=over 4
	38
	39	=item $self->finalize_headers($c)
	40
	41	=cut
	42
	43	sub finalize_headers {
	44	my ( $self, $c ) = @_;
	45	my $protocol = $c->request->protocol;
	46	my $status = $c->response->status;
	47	my $message = status_message($status);
	48	print "$protocol $status $message\015\012";
	49	$c->response->headers->date(time);
	50	$self->NEXT::finalize_headers($c);
	51	}
	52
	53	=item $self->finalize_read($c)
	54
	55	=cut
	56
	57	sub finalize_read {
	58	my ( $self, $c ) = @_;
	59
	60	# Never ever remove this, it would result in random length output
	61	# streams if STDIN eq STDOUT (like in the HTTP engine)
4f5ebacd	62	*STDIN->blocking(1);
fbcc39ad	63
	64	return $self->NEXT::finalize_read($c);
	65	}
	66
	67	=item $self->prepare_read($c)
	68
	69	=cut
	70
	71	sub prepare_read {
	72	my ( $self, $c ) = @_;
	73
	74	# Set the input handle to non-blocking
4f5ebacd	75	*STDIN->blocking(0);
fbcc39ad	76
	77	return $self->NEXT::prepare_read($c);
	78	}
	79
	80	=item $self->read_chunk($c, $buffer, $length)
	81
	82	=cut
	83
	84	sub read_chunk {
	85	my $self = shift;
	86	my $c = shift;
	87
	88	# support for non-blocking IO
4f5ebacd	89	my $rin = '';
4f5ebacd	90	vec( $rin, *STDIN->fileno, 1 ) = 1;
fbcc39ad	91
	92	READ:
	93	{
	94	select( $rin, undef, undef, undef );
4f5ebacd	95	my $rc = *STDIN->sysread(@_);
fbcc39ad	96	if ( defined $rc ) {
	97	return $rc;
	98	}
	99	else {
	100	next READ if $! == EWOULDBLOCK;
	101	return;
	102	}
	103	}
	104	}
	105
	106	=item run
	107
	108	=cut
	109
	110	# A very very simple HTTP server that initializes a CGI environment
	111	sub run {
37553dc8	112	my ( $self, $class, $port, $host, $options ) = @_;
fbcc39ad	113
4eeca0f2	114	$options \|\|= {};
4eeca0f2	115
37553dc8	116	# Setup restarter
	117	my $restarter;
	118	if ( $options->{restart} ) {
	119	my $parent = $$;
	120	unless ( $restarter = fork ) {
	121
7a1df403	122	# Prepare
	123	close STDIN;
	124	close STDOUT;
	125
37553dc8	126	# Index parent directory
	127	my $dir = File::Spec->catdir( $FindBin::Bin, '..' );
	128
	129	my $regex = $options->{restart_regex};
7a1df403	130	my $one = _index( $dir, $regex );
7a1df403	131	RESTART: while (1) {
31b426c0	132	sleep $options->{restart_delay} \|\| 1;
	133
	134	# check if our parent has died
	135	exit if ( getppid == 1 );
	136
7a1df403	137	my $two = _index( $dir, $regex );
	138	my $changes = _compare_index( $one, $two );
	139	if (@$changes) {
37553dc8	140	$one = $two;
7a1df403	141
	142	# Test modified pm's
	143	for my $file (@$changes) {
	144	next unless $file =~ /\.pm$/;
	145	if ( my $error = _test($file) ) {
	146	print STDERR
6844bc1c	147	qq/File "$file" modified, not restarting\n\n/;
7a1df403	148	print STDERR '*' x 80, "\n";
	149	print STDERR $error;
	150	print STDERR '*' x 80, "\n";
	151	next RESTART;
	152	}
	153	}
	154
	155	# Restart
	156	my $files = join ', ', @$changes;
5d1266ae	157	print STDERR qq/File(s) "$files" modified, restarting\n\n/;
7a1df403	158	kill( 1, $parent );
7a1df403	159	exit;
37553dc8	160	}
	161	}
	162	}
	163	}
31b426c0	164
	165	our $GOT_HUP;
	166	local $GOT_HUP = 0;
	167
	168	local $SIG{HUP} = sub { $GOT_HUP = 1; };
	169	local $SIG{CHLD} = 'IGNORE';
fbcc39ad	170
	171	# Handle requests
	172
	173	# Setup socket
	174	$host = $host ? inet_aton($host) : INADDR_ANY;
bd357f39	175	socket( HTTPDaemon, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
	176	\|\| die "Couldn't assign TCP socket: $!";
	177	setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
	178	\|\| die "Couldn't set TCP socket options: $!";
	179	bind( HTTPDaemon, sockaddr_in( $port, $host ) )
	180	\|\| die "Couldn't bind socket to $port on $host: $!";
	181	listen( HTTPDaemon, SOMAXCONN )
	182	\|\| die "Couldn't listen to socket on $port on $host: $!";
fbcc39ad	183	my $url = 'http://';
	184	if ( $host eq INADDR_ANY ) {
	185	require Sys::Hostname;
	186	$url .= lc Sys::Hostname::hostname();
	187	}
	188	else {
	189	$url .= gethostbyaddr( $host, AF_INET ) \|\| inet_ntoa($host);
	190	}
	191	$url .= ":$port";
	192	print "You can connect to your server at $url\n";
	193	my $pid = undef;
	194	while ( accept( Remote, HTTPDaemon ) ) {
	195
	196	# Fork
37553dc8	197	if ( $options->{fork} ) { next if $pid = fork }
fbcc39ad	198
	199	close HTTPDaemon if defined $pid;
	200
	201	# Ignore broken pipes as an HTTP server should
	202	local $SIG{PIPE} = sub { close Remote };
4f5ebacd	203	local $SIG{HUP} = ( defined $pid ? 'IGNORE' : $SIG{HUP} );
fbcc39ad	204
	205	local STDIN = \Remote;
	206	local STDOUT = \Remote;
	207	select STDOUT;
	208
	209	# Request data
	210	my $remote_sockaddr = getpeername( \*Remote );
	211	my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
	212	my $peername = gethostbyaddr( $iaddr, AF_INET ) \|\| "localhost";
	213	my $peeraddr = inet_ntoa($iaddr) \|\| "127.0.0.1";
	214	my $local_sockaddr = getsockname( \*Remote );
	215	my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
	216	my $localname = gethostbyaddr( $localiaddr, AF_INET )
	217	\|\| "localhost";
	218	my $localaddr = inet_ntoa($localiaddr) \|\| "127.0.0.1";
	219
	220	STDIN->blocking(1);
	221
	222	# Parse request line
	223	my $line = $self->_get_line( \*STDIN );
	224	next
	225	unless my ( $method, $uri, $protocol ) =
	226	$line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
	227
	228	# We better be careful and just use 1.0
	229	$protocol = '1.0';
	230
	231	my ( $path, $query_string ) = split /\?/, $uri, 2;
	232
	233	# Initialize CGI environment
	234	local %ENV = (
	235	PATH_INFO => $path \|\| '',
	236	QUERY_STRING => $query_string \|\| '',
	237	REMOTE_ADDR => $peeraddr,
	238	REMOTE_HOST => $peername,
	239	REQUEST_METHOD => $method \|\| '',
	240	SERVER_NAME => $localname,
	241	SERVER_PORT => $port,
	242	SERVER_PROTOCOL => "HTTP/$protocol",
	243	%ENV,
	244	);
	245
	246	# Parse headers
	247	if ( $protocol >= 1 ) {
	248	while (1) {
	249	my $line = $self->_get_line( \*STDIN );
	250	last if $line eq '';
	251	next
	252	unless my ( $name, $value ) =
	253	$line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/;
	254
	255	$name = uc $name;
	256	$name = 'COOKIE' if $name eq 'COOKIES';
	257	$name =~ tr/-/_/;
	258	$name = 'HTTP_' . $name
	259	unless $name =~ m/\A(?:CONTENT_(?:LENGTH\|TYPE)\|COOKIE)\z/;
	260	if ( exists $ENV{$name} ) {
	261	$ENV{$name} .= "; $value";
	262	}
	263	else {
	264	$ENV{$name} = $value;
	265	}
	266	}
	267	}
268
269	# Pass flow control to Catalyst
270	$class->handle_request;
271	exit if defined $pid;
272	}
273	continue {
274	close Remote;
275	}
276	close HTTPDaemon;
37553dc8	277
60c38e3e	278	if ($GOT_HUP) {
60c38e3e	279	$SIG{CHLD} = 'DEFAULT';
6844bc1c	280	wait;
6844bc1c	281	exec {$0}( ( ( -x $0 ) ? () : ($^X) ), $0, @{ $options->{argv} } );
60c38e3e	282	}
fbcc39ad	283	}
fbcc39ad	284
37553dc8	285	sub _compare_index {
	286	my ( $one, $two ) = @_;
	287	my %clone = %$two;
7a1df403	288	my @changes;
37553dc8	289	while ( my ( $key, $val ) = each %$one ) {
7a1df403	290	if ( !$clone{$key} \|\| ( $clone{$key} ne $val ) ) {
	291	push @changes, $key;
	292	}
37553dc8	293	delete $clone{$key};
37553dc8	294	}
7a1df403	295	for my $key ( keys %clone ) { push @changes, $key }
7a1df403	296	return \@changes;
37553dc8	297	}
37553dc8	298
fbcc39ad	299	sub _get_line {
	300	my ( $self, $handle ) = @_;
	301
	302	my $line = '';
	303
	304	while ( sysread( $handle, my $byte, 1 ) ) {
	305	last if $byte eq "\012"; # eol
	306	$line .= $byte;
	307	}
	308
	309	1 while $line =~ s/\s\z//;
	310
	311	return $line;
	312	}
	313
37553dc8	314	sub _index {
37553dc8	315	my ( $dir, $regex ) = @_;
5d1266ae	316	my %index;
	317	finddepth(
	318	{
	319	wanted => sub {
	320	my $file = File::Spec->rel2abs($File::Find::name);
	321	return unless $file =~ /$regex/;
	322	return unless -f $file;
	323	my $time = ( stat $file )[9];
	324	$index{$file} = $time;
37553dc8	325	},
5d1266ae	326	no_chdir => 1
	327	},
	328	$dir
	329	);
	330	return \%index;
37553dc8	331	}
37553dc8	332
7a1df403	333	sub _test {
7a1df403	334	my $file = shift;
6844bc1c	335	delete $INC{$file};
7a1df403	336	local $SIG{__WARN__} = sub { };
	337	open my $olderr, '>&STDERR';
	338	open STDERR, '>', File::Spec->devnull;
	339	eval "require '$file'";
	340	open STDERR, '>&', $olderr;
	341	return $@ if $@;
	342	return 0;
	343	}
	344
fbcc39ad	345	=back
fbcc39ad	346
45374ac6	347	=head1 SEE ALSO
45374ac6	348
fbcc39ad	349	L<Catalyst>, L<Catalyst::Engine>.
	350
	351	=head1 AUTHORS
	352
	353	Sebastian Riedel, <sri@cpan.org>
	354
	355	Dan Kubb, <dan.kubb-cpan@onautopilot.com>
45374ac6	356
fbcc39ad	357	=head1 THANKS
45374ac6	358
fbcc39ad	359	Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
45374ac6	360
	361	=head1 COPYRIGHT
	362
	363	This program is free software, you can redistribute it and/or modify it under
	364	the same terms as Perl itself.
	365
	366	=cut
	367
45374ac6	368	1;