#!/usr/bin/perl -w

use HTTP::Daemon;
use HTTP::Status;
use HTTP::Response;
use IPC::Open2;

# Port, na kterém chceme, aby démon poslouchal. Můžeme zadat i na
# příkazové řádce jako parametr.
my $PORT = 8081;
if (@ARGV) { $PORT = shift; }

# Tady je dobré dát nějaký rozumný "document root".
my $CGI_HOME = "/home/$ENV{USER}/public_html";

# Toto je handler, který zajistí, že ukončení potomci jsou opravdu
# ukončení, že se z nich nestanou zombie, které by skončily až
# s koncem hlavního handleru; některé (SysV) systémy vyžadují, aby
# handlerová rutina ovnovila registraci toho callbacku, tak to
# děláme.
sub clean_child {
	wait;
	$SIG{'CHLD'} = \&clean_child;
}
$SIG{'CHLD'} = \&clean_child;


# Vytvoření objektu HTTP::Daemon; $daemon je skalár obsahující
# referenci na ten objekt.
my $daemon = new HTTP::Daemon LocalPort => $PORT, Reuse => 1,
	Listen => 20;
if (not defined $daemon) { die "Cannot bind to $PORT: $@\n"; }

# A už máme objekt a můžeme na něm volat metody, třeba se ho zeptat,
# jaké je vlastně jeho URL.
warn "Please contact me at: <URL:", $daemon->url, ">\n";

# HTTP::Daemon dědí z nižších tříd (viz. manová stránka)
while (my $connection = $daemon->accept) {
	my $child = fork();
	unless (defined $child) { die "Fork failed: $!\n"; }
	if ($child) {
		# Rodič -- nic na práci, půjdeme zase poslouchat
		warn "Parent: forked child $child, fine. Will go to another accept.\n";
		$connection->close;
		next;
		}
	$connection->autoflush;
	my $num_req = 1;
	# Potomek postupně přebírá požadavky (ovšem se s klientem
	# nedomluví na keep-alive spojení, bude proveden stejně jen jeden)
	while (my $request = $connection->get_request) {
		warn "Child $$ started, request number $num_req.\n";
		$num_req++;
		# Vyčistíme tyto proměnné prostředí, ať je spuštěné
		# CGI skripty mají v pořádku
		delete $ENV{'QUERY_STRING'};
		delete $ENV{'CONTENT_LENGTH'};

		my $url = $request->url;
		my $path = $url->path;
		my $method = $request->method;
		warn "Child $$: $method $path\n";
		if (defined $url->query) {
			$ENV{'QUERY_STRING'} = $url->query;
			}
		if ($method ne 'GET' and $method ne 'POST') {
			$connection->send_error(RC_FORBIDDEN);
			next;
			}
		$ENV{'REQUEST_METHOD'} = $request->method;
		$ENV{'CONTENT_LENGTH'} = length($request->content);

		# Ošetříme cestu na adresář a příponu .cz
		if (-d "$CGI_HOME$path") { $path .= "index.html"; }
		if (not -f "$CGI_HOME$path" and -f "$CGI_HOME$path.cz") {
			$path .= ".cz";
			}
		warn "Child $$: Will try $CGI_HOME$path\n";

		# Spuštění CGI skriptů
		if ($path =~ /\.cgi$/ and -x "$CGI_HOME$path") {
			warn "Child $$: Trying to run $CGI_HOME$path\n";
			local (*CGI, *WTR);
			
			eval { open2 \*CGI, \*WTR, "$CGI_HOME$path"; };
			if ($@) {
				$connection->send_error(RC_NOT_FOUND);
				warn "Child $$: Error: $@\n";
				next;
				}
			if ($method eq 'POST') {
				print WTR $request->content;
				}
			close WTR;

			my $headers;

			local $/ = "\r\n\r\n";
			$headers = <CGI>;

			my $response = new HTTP::Response(RC_OK);
			for my $line ($headers =~ /(.+)/g) {
				my ($field, $val) = ($line =~ /(.*):(.*)/);
				next if not defined $val;
				$response->push_header($field, $val);
				}
			my $content = join '', <CGI>;

			close CGI;
			$response->content($content);	
			$connection->send_response($response);
			}

		# Pošleme statický soubor
		elsif (-f "$CGI_HOME$path" and open FILE, "$CGI_HOME$path") {
			my $response = new HTTP::Response(RC_OK);
	
			# Různé hlavičky
			if ($path =~ /\.html(\.cz)?$/) {
				$response->push_header('Content-Type',
					'text/html; charset=iso-8859-2');
				}
			elsif ($path =~ /\.gif$/) {
				$response->push_header('Content-Type',
					'image/gif');
				}
			else {
				$response->push_header('Content-Type',
					'text/plain');
				}
			my $content = '';
			while (<FILE>) { $content .= $_; }
			close FILE;
			$response->content($content);
			$connection->send_response($response);
			}
		else {
			$connection->send_error(RC_BAD_REQUEST, "I do not know what you mean by `$path', sorry\n");
			}
		}
	continue {
		warn "Child $$: finished response, going back to wait.\n";
		}
	warn "Child $$: no more requests, exitting.\n";
	$connection->close;
	undef $connection;
	exit 0;
	}
undef $daemon;