#!/usr/bin/perl

# ppcgid - pure perl cgi server
# See the bottom of this file for the POD documentation.  Search for the
# string '=head'.

our $VERSION=0.92;

use strict;

use POSIX;
use IO::Socket;
use IO::Select;
use IO::String;
use IO::File;
use LWP::UserAgent;
use Getopt::Long;

##### CONFIGURE HERE #####
$ENV{'SERVER_SOFTWARE'} = 'Apache';

my $WRITE_TIMEOUT = 20;			        # time to wait to complete transmission
my $READ_TIMEOUT = 5;				# time to wait for get request
my $MAX_LINE = 1024;			    	# maximum size of a single header/get line
my $HANDLER = '/var/www/handler.pl';		# perl cgi program to handle requests
my $LOCAL_ADDR = '0.0.0.0';			# listen address
my $LOCAL_PORT = 80;				# listen port
my $STATUS_HOST = 'noakai[.]com$';      	# respond to STATUS only if host matches this
my $DEBUG = 0;

# modules for your handler program
use CGI::Carp;
use CGI qw(-oldstyle_urls -nph);
##########################

##### OVERRIDE CONF ######
GetOptions("port=i"=>\$LOCAL_PORT, "handler=s"=>\$HANDLER, "debug"=>\$DEBUG);

select STDERR;
$|=0;
select STDOUT;
$|=0;

my $main_socket = new IO::Socket::INET(Proto=>'tcp', LocalAddr=>$LOCAL_ADDR, LocalPort=>$LOCAL_PORT, Listen => 1, Reuse=>1, Timeout=>5);

die "startup failed: $!\n" unless $main_socket;

my $read_set = new IO::Select();
my $write_set = new IO::Select();

$read_set->add($main_socket);

my $start_time = time();
my $ok_count = 0;
my $req_count = 0;

my %codes = (
	'200', 'OK',
	'201', 'Created',
	'202', 'Accepted',
	'204', 'No Content',
	'301', 'Moved Permanently',
	'302', 'Moved Temporarily',
	'304', 'Not Modified',
	'400', 'Bad Request',
	'401', 'Unauthorized',
	'403', 'Forbidden',
	'404', 'Not Found',
	'500', 'Internal Server Error',
	'501', 'Not Implemented',
	'502', 'Bad Gateway',
	'503', 'Service Unavailable',
);

my $WIN32 = ($^O =~ /Win32/);

$SIG{'TERM'} = \&sig_term;
$SIG{'INT'} = \&sig_term;

#$SIG{'HUP'} = \&sig_hup;

my $handler_time;
my $handler_coderef;
my $handler_codeerr;

while (1) {  #Infinite loop
    # select() blocks until a socket is ready to be read or written
    
    my ($new_readable, $new_writable, $new_error) = IO::Select->select($read_set, $write_set, $read_set, undef);
					 
    # If it comes here, there is at least one handle
    # to read from or write to. For the moment, worry only about 
    # the read side.

    my $sock;
    foreach $sock (@$new_readable) {
        if ($sock == $main_socket) {
            my $new_sock = $sock->accept();
	    #logmsg("incoming connection from: " , $new_sock->peerhost());
            # Add it to the list, and go back to select because the 
            # new socket may not be readable yet.
	    if ($new_sock) {
		    ++$req_count;
		    if ($WIN32) {
		    	ioctl($new_sock, 0x8004667e, pack("I", 1));
		    } else {
		   	fcntl($new_sock, F_SETFL(), O_NONBLOCK());
		    }
	            $read_set->add($new_sock);
		    *$new_sock{HASH}->{time} = time();
	    }
        } else {
            # It is an ordinary client socket, ready for reading.
	    my $nodata = 1;
	    my $buf;
            
	    my $bytes_read = sysread($sock, $buf, 4096);

	    if ($bytes_read == 0) {
	    	    $read_set->remove($sock);
		    
	    	    if (!*$sock{HASH}->{resp}) {
		    	logmsg("connection closed before response", $sock);
			close_sock($sock);
		    }
		    next;
	    }

	    if (*$sock{HASH}->{buf}) {
	    	$buf = *$sock{HASH}->{buf} . $buf;
		delete *$sock{HASH}->{buf};
	    }

	    my @lines = split(/(?:\r\n|\n)/,$buf,-1);

	    if ($lines[$#lines]) {
	    	# partial line
	    	*$sock{HASH}->{buf} = $lines[$#lines];
	    }
	    
	    # last element is either empty or a partial line
	    splice @lines, $#lines, 1;

	    foreach $buf (@lines) {
	    	# already queued reponse, discard input
	    	next if *$sock{HASH}->{resp};

		chomp($buf);
		
	    	if (length($buf) > $MAX_LINE) {
			http_error($sock, 400, "too much data on request");
			close_sock($sock);
		} elsif (!*$sock{HASH}->{url}) {
			my ($method, $url, $proto, $garbage) = split(/\s+/,$buf);
			if ($garbage) {
				http_error($sock, 400, "garbage request");
			} else {
				#logmsg("mthd=$method, url=$url, prot=$proto", $sock);
				$url =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # unescape.
				*$sock{HASH}->{url} = $url;
				# note: you can start processing the requests here
				# instead of waiting for the headers, if you want
			}
		} elsif ($buf =~ /^\s*$/) {
			# blank line triggers processing
			# or you can trigger it earlier and display an error here
			process_request($sock);
			# http_error($sock, 404, "no host specified");
		} else {
			my ($header, $value) = ($buf =~ /^([^: ]+)\s*:\s*(.*)$/);

			# todo, make the accepted header list configurable
			# so we store as many headers as we need, and never more
			
			if (lc($header) eq 'host') {
				*$sock{HASH}->{host} = lc($value);
				# logmsg("Host: " . *$sock{HASH}->{host});
				# process_request($sock);
			}
			if (lc($header) eq 'referer') {
				*$sock{HASH}->{referer} = lc($value);
			}
		}
            }
        }
    }
    
    foreach $sock ($write_set->can_write(0)) {
    	#logmsg("writable");
	if (*$sock{HASH}->{close}) {
		close_sock($sock);
	} elsif (*$sock{HASH}->{resp}) {
		my $nb = syswrite($sock, *$sock{HASH}->{resp}, length(*$sock{HASH}->{resp}), *$sock{HASH}->{resp_offset});
		if (!$nb) {
			logmsg("socket failed to write", $sock);
			close_sock($sock);
		} else {
			*$sock{HASH}->{resp_offset}+= $nb;
			if (*$sock{HASH}->{resp_offset} >= length(*$sock{HASH}->{resp})) {
				#free buffer
				delete *$sock{HASH}->{resp};
				#logmsg("done writing, close socket on next writable");
				*$sock{HASH}->{close} = 1;
			}
		}
	} else {
		logmsg("no data for response", $sock);
		close_sock($sock);
	}
    }

    foreach $sock (@$new_error) {
    	die "main socket died" 
		if ($sock == $main_socket);
	
    	logmsg("error on socket read", $sock);
	close_sock($sock);
    }
    
    foreach $sock ($read_set->handles()) {
    	next if ($sock == $main_socket);
	
    	my $duration = (time() - *$sock{HASH}->{time});
	if (*$sock{HASH}->{resp}) {
		if ($duration > $WRITE_TIMEOUT) {
			logmsg("write timeout", $sock);
			close_sock($sock);
		}
	} else {
		if ($duration > $READ_TIMEOUT) {
			#logmsg("read timeout");
			close_sock($sock);
		}
	}
    }    
}

sub logmsg { 
	my ($msg, $sock, $code) = @_;
	my $time = time();
	my $localtime = localtime($time);
	$code = 0 if !$code;
	my ($url, $ip, $host, $dur);
	if ($sock) {
		$url = *$sock{HASH}->{url};
	        $ip = $sock->peerhost();
	        $host = *$sock{HASH}->{host};
		$dur = $time-*$sock{HASH}->{time};
	}
 
	print STDERR "$localtime\t$msg\t$ip\t$host\t$url\t$dur\n";
}

sub http_error { 
	my ($sock, $code, $detail) = @_;
	my $msg = "$code " . $codes{$code};
	logmsg($detail, $sock, $code);
	*$sock{HASH}->{resp} .= "HTTP/1.0 $msg\nContent-type: text/html\n\n";
	*$sock{HASH}->{resp} .= "<I>HTTPD</I> : $detail : $msg\n";
	$write_set->add($sock);
#	148.235.173.22 - - [23/May/2005:10:43:32 -0700] "GET /invest.php HTTP/1.1" 301 212 "-" "-" "www.jordantrust.com"
}

sub process_request
{
	my ($sock) = @_;

	if (*$sock{HASH}->{url} eq '/STATUS' && *$sock{HASH}->{host} =~ /$STATUS_HOST/i) {
		*$sock{HASH}->{resp} .= "HTTP/1.0 200 OK\nContent-type: text/plain\n\n";

		*$sock{HASH}->{resp} .= "Url     : " . *$sock{HASH}->{url} . "\n";
		*$sock{HASH}->{resp} .= "Host    : " . *$sock{HASH}->{host} . "\n";

		*$sock{HASH}->{resp} .= "Readers : " . $read_set->count() . "\n";
		*$sock{HASH}->{resp} .= "Writers : " . $write_set->count() . "\n";

		my $uptime = (time() - $start_time);
		my $req_ps = sprintf("%2.2f", 1.0*$req_count/$uptime);
		my $ok_ps = sprintf("%2.2f", 1.0*$ok_count/$uptime);
		*$sock{HASH}->{resp} .= "Uptime  : " . (time() - $start_time) . " sec\n";
		*$sock{HASH}->{resp} .= "Hits All: $req_count ($req_ps/sec)\n";
		*$sock{HASH}->{resp} .= "Hits OK : $ok_count ($ok_ps/sec)\n";
		
	} else {
		my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)
	           = stat($HANDLER);

		if ($mtime > $handler_time) {
			open IN, $HANDLER;
			local $/ = undef;
			my $code = <IN>;
			close IN;
			$handler_coderef = eval "sub {$code};";
			if (!$handler_coderef) {
				$handler_codeerr = $@;
				$handler_codeerr =~ s/\n/ /g;
			}
			$handler_time = $mtime;
		}

		if ($handler_coderef) {
			my $io = IO::String->new(*$sock{HASH}->{resp});
			select($io);
			$ENV{REQUEST_URI} = *$sock{HASH}->{url};
			$ENV{REMODE_ADDR} = $sock->peerhost();
			$ENV{HTTP_REFERER} = *$sock{HASH}->{referer};
			$ENV{HTTP_HOST} = *$sock{HASH}->{host};
			&$handler_coderef;
			logmsg("ok",$sock);
			++$ok_count;
		} else {
			http_error($sock, 500, "invalid handler ($handler_codeerr)");
		}
	}
	$write_set->add($sock);
	#logmsg "added socket to write set";

}

sub close_sock
{
	my ($sock) = @_;
	%{*$sock{HASH}} = ();
	$read_set->remove($sock);
	$write_set->remove($sock);
	close($sock);
}

sub sig_term
{
        logmsg("terminated by user");
        exit(0);
}

__END__


=head1 NAME

   ppcgid - This is a pure perl single-threaded trivial httpd server

=head1 VERSION

   This document refers to version 0.92 of ppcgid

=head1 REQUIREMENTS

   It needs the following perl Modules:

      POSIX
      IO::Socket
      IO::Select
      IO::String
      LWP::UserAgent
      CGI
      CGI::Carp

=head1 DESCRIPTION

   Start from your inittab or init.d.  STDERR gets tab-delimited logs.

       ppcgid 2>/var/log/ppcgid.log&

   You're responsible for actually handling the HTTP requests by 
   writing a perl CGI application.

       $HANDLER='/path/to/cgi.pl';

   The application should be a valid nph cgi program.  Your program 
   should not be written to block on IO, or you will defeat the speed
   of ppcgid.  Creative use of caching and hash tables should help you.

   Don't bother re-use-ing any of the required modules, since your 
   program is running in the same namespace.  In fact, you're way better 
   off use-ing stuff at the top of the ppcgid main, rather than your module.
   
   If you want a webserver that you can tweak for your perl web 
   application and can handle a high load, this is fine.  It ran 400 
   requests per second with a very complex CGI program on a 500MHZ box.

   The same program hung on mod_perl under the same load, so I use 
   ppcgid now for that app.   It also gracefully degrades under a load.  
   It also supports multiple timeouts, which all web servers should.

=head1 BUGS

   Report any bug to: 'Erik Aronesty' <erik@q32.com>

=head1 AUTHOR

   Erik Aronesty erik@q32.com

=head1 COPYRIGHT

   License: GNU GPL http://www.fsf.org/copyleft/gpl.html

   Copyright (C) 2002 Erik Aronesty

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
   USA

=cut