tests: add a simple webserver written in perl.

This should be the web server to test against in the upcoming selftest suite. This web server will evolve as the test suite grows. Currently, it just returns a web site quoting the request and a fortune (if fortune is installed...) for whatever request it gets. The option to provide a document root is already present. Michael
author: Michael Adam <obnox@samba.org> 2009-09-10 01:13:01 +0200
committer: Michael Adam <obnox@samba.org> 2009-09-10 01:13:01 +0200
commit: a39d7cd8d87b30ff86ba9e3d3273f6da031dc65c (patch)
tree: fc41c652ab11da3a254885ed4c9322b4cd7af526
parent: e39da7d0b277a64bfcb4098b95ad077276f4fa07 (diff)
1 files changed, 276 insertions, 0 deletions
diff --git a/tests/scripts/webserver.pl b/tests/scripts/webserver.pl
new file mode 100755
index 0000000..a1d171d
--- /dev/null
+++ b/tests/scripts/webserver.pl
@@ -0,0 +1,276 @@
+#!/usr/bin/perl -w
+
+# Simple WEB server.
+#
+# Inspired by some examples from the perlipc and other perl manual pages.
+#
+# Copyright (C) 2009 Michael Adam
+#
+# License: GPL
+
+use strict;
+
+use IO::Socket;
+use IO::Select;
+use Carp;
+use POSIX qw(setsid :sys_wait_h);
+use Errno;
+use Getopt::Long;
+use Pod::Usage;
+use Fcntl ':flock'; # import LOCK_* constants
+
+my $EOL = "\015\012";
+
+my $port = 2345;
+my $proto = getprotobyname('tcp');
+my $pid_file = "./webserver.pid";
+my $log_dir = "./";
+my $access_log_file;
+my $error_log_file;
+my $document_root = "./";
+my $help = 0;
+
+sub create_child($$$);
+
+sub logmsg {
+	print STDERR "[", scalar localtime, ", $$] $0: @_\n";
+}
+
+sub start_server($$) {
+	my $proto = shift;
+	my $port = shift;
+	my $server;
+
+	$server = IO::Socket::INET->new(Proto => $proto,
+					LocalPort => $port,
+					Listen => SOMAXCONN,
+					Reuse => 1);
+
+	logmsg "server started listening on port $port";
+
+	return $server;
+}
+
+sub REAPER {
+	local $!;   # don't let waitpid() overwrite current error
+
+	while ((my $pid = waitpid(-1,WNOHANG)) > 0 && WIFEXITED($?)) {
+		logmsg "reaped $pid" . ($? ? " with exit code $?" : '');
+	}
+
+	$SIG{CHLD} = \&REAPER;
+}
+
+sub child_action($) {
+	my $client = shift;
+	my $client_ip = shift;
+
+	logmsg "client_action: client $client_ip";
+
+	$client->autoflush();
+
+	my $fortune_bin = "/usr/games/fortune";
+	my $fortune = "";
+	if ( -x $fortune_bin) {
+		$fortune = qx(/usr/games/fortune);
+		$fortune =~ s/\n/$EOL/g;
+	}
+
+	my $request = "";
+	while (my $request_line = <$client>) {
+		$request .= $request_line;
+		last if ($request_line eq $EOL);
+	}
+
+	logmsg  "request:\n" .
+		"------------------------------\n" .
+		"$request" .
+		"------------------------------";
+
+	print $client "HTTP/1.0 200 OK$EOL";
+	print $client "Server:  Tinyproxy Test Web Server$EOL";
+	print $client "Content-Type: text/html$EOL";
+	print $client "$EOL";
+	print $client "<html>$EOL";
+	print $client "<h1>Tinyproxy test WEB server</h1>$EOL";
+	print $client "<h2>Fortune</h2>$EOL";
+	if ($fortune) {
+		print $client "<pre>$fortune</pre>$EOL";
+	} else {
+		print $client "Sorry, no $fortune_bin not found.$EOL";
+	}
+	print $client "<h2>Your request:</h2>$EOL";
+	print $client "<pre>$request<pre>$EOL";
+	print $client "</html>$EOL";
+
+	close $client;
+
+	return 0;
+}
+
+sub create_child($$$) {
+	my $client = shift;
+	my $action = shift;
+	my $client_ip = shift;
+
+	unless (@_ == 0 && $action && ref($action) eq 'CODE') {
+	    confess "internal error. create_child needs code reference as argument";
+	}
+
+	my $pid = fork();
+	if (not defined($pid)) {
+		# error
+		logmsg "cannot fork: $!";
+		return;
+	} elsif ($pid) {
+		# parent
+		logmsg "child process created with pid $pid";
+		return;
+	} else {
+		# child
+		exit &$action($client, $client_ip);
+	}
+}
+
+sub process_options() {
+	my $result = GetOptions("help|?" => \$help,
+				"port=s" => \$port,
+				"pid-file=s" => \$pid_file,
+				"log-dir=s" => \$log_dir,
+				"root|document-root=s" => \$document_root);
+	die "Error reading cmdline options! $!" unless $result;
+
+	pod2usage(1) if $help;
+
+	# some post-processing:
+
+	($port) = $port =~ /^(\d+)$/ or die "invalid port";
+	$access_log_file = "$log_dir/webserver.access_log";
+	$error_log_file = "$log_dir/webserver.error_log";
+}
+
+sub daemonize() {
+	umask 0;
+	chdir "/" or die "daemonize: can't chdir to /: $!";
+	open STDIN, "/dev/null" or
+		die "daemonize: Can't read from /dev/null: $!";
+	open STDOUT, ">> $access_log_file" or
+		die "daemonize: Can't write to '$access_log_file': $!";
+	open STDERR, ">> $error_log_file" or
+		die "daemonize: Can't write to '$error_log_file': $!";
+
+	my $pid = fork();
+	die "daemonize: can't fork: $!" if not defined($pid);
+	exit(0) if $pid != 0; # parent
+
+	# child (daemon)
+	setsid or die "damonize: Can't create a new session: $!";
+}
+
+sub get_pid_lock() {
+	open LOCKFILE, "> $pid_file" or
+		die "Error opening pid-file $pid_file: $!";
+	unless (flock(LOCKFILE, LOCK_EX|LOCK_NB)) {
+		my $other_pid = qx(cat $pid_file);
+		print "Webserver is already running (pid $other_pid)";
+		exit(0);
+	}
+
+	print LOCKFILE "$$";
+}
+
+sub release_pid_lock() {
+	flock(LOCKFILE, LOCK_UN);
+	close LOCKFILE;
+}
+
+# "main" ...
+
+$|=1; # autoflush
+
+process_options();
+
+daemonize();
+
+get_pid_lock();
+
+$SIG{CHLD} = \&REAPER;
+
+my $server = start_server($proto, $port);
+my $slct = IO::Select->new($server);
+
+while (1) {
+	my @ready_for_reading = $slct->can_read();
+	foreach my $fh (@ready_for_reading) {
+		if ($fh != $server) {
+			logmsg "select: fh ready for reading but not server",
+				"don't know what to do...";
+		}
+
+		# new connection:
+		my $client = $server->accept() or do {
+			# try again if accept() returned because
+			# a signal was received
+			if ($!{EINTR}) {
+				logmsg "accept: got signal EINTR ...";
+				next;
+			}
+			die "accept: $!";
+		};
+		my $client_ip = inet_ntoa($client->peeraddr);
+		logmsg "connection from $client_ip at port " . $client->peerport;
+		create_child($client, \&child_action, $client_ip);
+		close $client;
+	}
+}
+
+# never reached...
+logmsg "Server done - ooops!\n";
+
+release_pid_lock();
+
+exit(0);
+
+__END__
+
+=head1 webserver.pl
+
+A simple WEB server written in perl.
+
+=head1 SYNOPSIS
+
+webserver.pl [options]
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<--help>
+
+Print a brief help message and exit.
+
+=item B<--port>
+
+Specify the port number for the server to listen on.
+
+=item B<--root|--document-root>
+
+Specify the document root directory from which to serve web content.
+
+=item B<--log-dir>
+
+Specify the directory where the log files should be stored.
+
+=item B<--pid-file>
+
+Specify the location of the  pid lock file.
+
+=back
+
+=head1 DESCRIPTION
+
+This is a very simple web server. It currently does not deliver the specific web
+page requested, but constructs the same kind of answer for each request, citing
+a fortune if fortune is available, and printing the originating request.
+
+=cut
author	Michael Adam <obnox@samba.org>	2009-09-10 01:13:01 +0200
committer	Michael Adam <obnox@samba.org>	2009-09-10 01:13:01 +0200
commit	a39d7cd8d87b30ff86ba9e3d3273f6da031dc65c (patch)
tree	fc41c652ab11da3a254885ed4c9322b4cd7af526
parent	e39da7d0b277a64bfcb4098b95ad077276f4fa07 (diff)