#!/usr/bin/perl -w

=head1 serve_http.pl

=item Written: 20021230

=back

=item Creator: Andrew Robertson

=back

=item Revised: N/A

=back

=item Version: 1.0

=back

=item License: GPL 2

=back

    Copyright (C) 2002 Andrew Robertson <critter_75075@yahoo.com>

    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

Description:

  serve_http.pl is a simple multi-process web server.

References:

  Some of serve_http.pl is based on a demo server in the Advanced Perl
  Programming book by Siram Srinivasan, First Printing Copyright 1997.

  Also used where www.deja.com, and perldoc perlfunc.

Global Variables:

	my @live_children = ([pid, socket reference],...) # List of all
		live children and their respective sockets.
	my $message_level = integer; # Logging level
	my $child_timeout = seconds; # Time to let children live

=cut

use strict;
use IO::Socket::INET;
use POSIX ":sys_wait_h";

my @live_children;		# Store children PID's with their socket references
my $message_level = 2;
my $child_timeout = 360; # six minutes

# Clean up after spawned children.

################################################################################

=head2 sub logmessage

Description:

  logmessage handles messages, including errors.  You may configure this to write to files
  or just to print the messages.

Levels:
	0:	Major program events (starting and stopping)
	1:	Initialization
	2:	Main HTTP transactions
	3:	Subroutine start and stop
	10:	Program errors
	11:	HTTP errors

=cut

sub logmessage {
	my ($level, $block, $message) = @_;
	if ($level <= $message_level) {
		print $block, ' ', $message, "\n";
	} elsif ($level >= 10) {
		print "Error: $block $message\n";
	}
}

################################################################################

=head2 sub clean

Description:

  Using the @live_children global variable, subroutine clean closes the sockets for dead children.

=cut

sub clean {

	logmessage(3, 'sub clean', 'started');

	my @new_children_list;
	my $temp_array;
	foreach $temp_array(@live_children) {
		# use posix type non blocking wait
		my $retval = waitpid($$temp_array[0], &WNOHANG);
		if ($retval != 0) {
			close ($$temp_array[1]);
		} else {
			push(@new_children_list, $temp_array);
		}
	}
	@live_children = @new_children_list;
	logmessage(3, 'sub clean', 'ended');
	return (1);
}

################################################################################

=head2 sub return_document

Description:

  A simple routine, could be any behavior you wish, including opening files
  and printing them.  By default, simply prints the HTTP headers, some text,
  and the requested document name.

  Logic for non-existant files is also at your discretion.  For now, to
  trigger the 404 error you simple request the file '/nofile'.

  You must set the LocalAddr and LocalPort parameters on the ...INET->new
  function.  Also, on most systems you must be root to take control of
  lower port numbers, such as 80.  To do this as a user other than root,
  you may need to use a number like 5000 for the port.

=cut

sub return_document {
	logmessage(3, 'sub return_document', 'started');
	
	my ($socket, $document, $http_ver) = @_;

	if ($document eq '/nofile') {
		print $socket "$http_ver 404 File not found\n";
		print $socket "Server: serve_http.pl/1.0\n";
		print $socket "Content-Type: text/plain\n\n";
		print $socket "404 Not found!\n";
	} else {
		print $socket "$http_ver 200 OK\n";
		print $socket "Server: serve_http.pl/1.0\n";
		print $socket "Content-Type: text/plain\n\n";
		print $socket "Configure return_document procedure!\n";
		print $socket "$document\n";
	}

	logmessage(3, 'sub return_document', 'ended');

}

################################################################################

sub main {
	logmessage(3, 'sub main', 'started');
	$SIG{CHLD} = sub {clean;};
	my $socket;	# Master socket
	my $new_sock;	# sub socket connections
	my $buf;	# received text
	
	$socket = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
					LocalPort => '5000',
					Listen => 5,
					Reuse => 1,
					Proto => 'tcp');
	
	unless ($socket) {print 'Unable to capture socket'; exit;}
	
	# Start looping for new connections.  The procedure clean is called to attempt
	# to remove children clients a second time.
	while (clean and $new_sock = $socket->accept()) {
		my $pid = fork;
		die "Cannot fork: $!" unless defined($pid);
		if ($pid == 0) { # I am a daughter
			# Set daughter to kill herself if she gets too old
			$SIG{ALRM} = sub {logmessage(10, 'serve_http.pl child', 'timeout'); exit(1);};
			alarm($child_timeout);
			
			if (defined($buf = <$new_sock>)) {
				chomp($buf);
				if ($buf =~ /^GET ([^\s]+) (HTTP\/1\.[01])/i) {
					logmessage(2, '', $buf); 
					my $document = $1;
					my $http_ver = $2;
					my $s_temp = ' ';
					until (not defined($s_temp) or ($s_temp =~ /^\n|\r/)) {
						$s_temp = <$new_sock>;
					}
					return_document($new_sock, $document, $http_ver);
				} elsif ($buf =~ /^GET ([^\s]+)/i) {
					logmessage(2, '', $buf);
					return_document($new_sock, $1, 'HTTP/0.9');
				} else {
					logmessage(11, 'HTTP/1.0 501', $buf);
					print $new_sock "HTTP/1.0 501 Method Not Implemented\n";
				}
				exit(0);
			}
		} else {
			push (@live_children, [$pid, $new_sock]);
		}
	}
	
	close ($socket);
	logmessage(3, 'sub main', 'ended');
}
logmessage(0, 'serve_http.pl', 'started');
main;
exit(0);