package CGI::Application::HTTP;

use strict;
use base 'CGI::Application';
use HTTP::Status;
use Socket;
use IO::Socket::INET ();
use IO::Select       ();
use CGI;


our $VERSION = '0.01_01';

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

    $options ||= {};

    my $restart = 0;
    local $SIG{CHLD} = 'IGNORE';

    my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' };
    my $addr = $host ? inet_aton($host) : INADDR_ANY;
    if ( $addr eq INADDR_ANY ) {
        require Sys::Hostname;
        $host = lc Sys::Hostname::hostname();
    }
    else {
        $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr);
    }

    # Handle requests

    # Setup socket
    my $daemon = IO::Socket::INET->new(
        Listen    => SOMAXCONN,
        LocalAddr => inet_ntoa($addr),
        LocalPort => $port,
        Proto     => 'tcp',
        ReuseAddr => 1,
        Type      => SOCK_STREAM,
      )
      or die "Couldn't create daemon: $!";

    my $url = "http://$host";
    $url .= ":$port" unless $port == 80;

    print "You can connect to your server at $url\n";

    $self->_keep_alive( $options->{keepalive} || 0 );

    my $parent = $$;
    my $pid    = undef;
    while ( accept( Remote, $daemon ) )
    {    # TODO: get while ( my $remote = $daemon->accept ) to work

        select Remote;

        # Request data

        Remote->blocking(1);

        next
          unless my ( $method, $uri, $protocol ) =
          $self->_parse_request_line( \*Remote );

        unless ( uc($method) eq 'RESTART' ) {

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

            $self->_handler( $port, $method, $uri, $protocol );

            $daemon->close if defined $pid;

        }
        else {
            my $sockdata = $self->_socket_data( \*Remote );
            my $ipaddr   = _inet_addr( $sockdata->{peeraddr} );
            my $ready    = 0;
            while ( my ( $ip, $mask ) = each %$allowed and not $ready ) {
                $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip);
            }
            if ($ready) {
                $restart = 1;
                last;
            }
        }

        exit if defined $pid;
    }
    continue {
        close Remote;
    }
    $daemon->close;

    if ($restart) {
        $SIG{CHLD} = 'DEFAULT';
        wait;
        exec $^X . ' "' . $0 . '" ' . join( ' ', @{ $options->{argv} } );
    }

    exit;
}

sub _handler {
    my ( $self, $port, $method, $uri, $protocol ) = @_;

    # Ignore broken pipes as an HTTP server should
    local $SIG{PIPE} = sub { close Remote };

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

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

    my $sockdata    = $self->_socket_data( \*Remote );
    my %copy_of_env = %ENV;
    my %copy_of_self = %{$self};
    
    my $sel = IO::Select->new;
    $sel->add( \*STDIN );

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

        # Initialize CGI environment
        local %ENV = (
            PATH_INFO    => $path         || '',
            QUERY_STRING => $query_string || '',
            REMOTE_ADDR     => $sockdata->{peeraddr},
            REMOTE_HOST     => $sockdata->{peername},
            REQUEST_METHOD  => $method || '',
            SERVER_NAME     => $sockdata->{localname},
            SERVER_PORT     => $port,
            SERVER_PROTOCOL => "HTTP/$protocol",
            %copy_of_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 CGI::App
        $ENV{SERVER_SOFTWARE} = "CGI::Application::HTTP/$VERSION";
        $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
        $ENV{REQUEST_URI} = $uri;

        my $copy_of_self = bless \%copy_of_self,ref $self;
        CGI::_reset_globals();
        $copy_of_self->{__QUERY_OBJ} = CGI->new();
    	
    	$ENV{CGI_APP_RETURN_ONLY} = 1;
        my $output = $copy_of_self->SUPER::run();
        
        # Generate Status Line
        my $message=200;
        foreach (split /\n/,$copy_of_self->_send_headers){
            if($_ =~ /^Status:\s+(\d+)/){
                $message=$1;
            }
        }
        print STDOUT $ENV{SERVER_PROTOCOL}. " " . $message . " "  . status_message($message) . "\015\012";
        print STDOUT $output;

        my $connection = lc $ENV{HTTP_CONNECTION};
        last
          unless $self->_keep_alive()
          && index( $connection, 'keep-alive' ) > -1
          && index( $connection, 'te' ) == -1          # opera stuff
          && $sel->can_read(5);

        last
          unless ( $method, $uri, $protocol ) =
          $self->_parse_request_line( \*STDIN );
    }

    close Remote;
}



sub _keep_alive {
    my ( $self, $keepalive ) = @_;

    my $r = $self->{_keepalive} || 0;
    $self->{_keepalive} = $keepalive if defined $keepalive;

    return $r;

}

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

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

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

    my $remote_sockaddr = getpeername($handle);
    my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
    my $local_sockaddr = getsockname($handle);
    my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);

    my $data = {
        peername => gethostbyaddr( $iaddr, AF_INET ) || "localhost",
        peeraddr => inet_ntoa($iaddr) || "127.0.0.1",
        localname => gethostbyaddr( $localiaddr, AF_INET ) || "localhost",
        localaddr => inet_ntoa($localiaddr) || "127.0.0.1",
    };

    return $data;
}

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 _inet_addr { unpack "N*", inet_aton( $_[0] ) }

sub mode_param {
	my $self = shift;
	my $mode_param;	
	my %p;

	if ((scalar @_) == 1) {
		$mode_param = $_[0];
	} elsif ( @_ > 1) {
		croak("CGI::Application->mode_param() : You gave me an odd number of parameters to mode_param()!") unless ((@_ % 2) == 0);
		%p = @_;
		$mode_param = $p{param};
		if ( $p{path_info} ) {
		    my $default_mode_param = $mode_param;
		    $mode_param = sub {
		        my $pi = shift->query->path_info();
		        return $default_mode_param if( !defined $pi || !length $pi);
		        my $idx = $p{path_info};
		        $idx -= 1 if ($idx > 0) ;
		        $pi =~ s!^/!!;
		        $pi = (split q'/', $pi)[$idx] || '';
		        return (length $pi) ?  $pi : $default_mode_param;
		    };
		}
	}

	# If data is provided, set it
	if (defined($mode_param)) {
		$self->{__MODE_PARAM} = $mode_param;
	}
	
    $self->{__MODE_PARAM} = 'rm' unless (exists($self->{__MODE_PARAM}));
	return $self->{__MODE_PARAM};
}

1;