#!/usr/misc/bin/perl

# ------------------------------------------------------------------# 
#  Redirector 1.0 (alpha)                                           # 
#                                                                   #
#  Copyright 1995 John R. R. Leavitt (jrrl@cmu.edu)                 # 
#                                                                   # 
#  Redirects server requests, while preserving paths.               # 
#                                                                   # 
#  Usage: redirector <new-server-prefix> [<port>]                   # 
#                                                                   # 
#  If <port> is unspecified, uses port 80.                          # 
#                                                                   # 
#  Example:  redirector "http://www.foo.com" 8001                   #
#  This would redirect requests on port 8001 of the running machine # 
#  to port 80 (www default) of www.foo.com.                         # 
#                                                                   # 
# ------------------------------------------------------------------# 
#  Disclaimer                                                       #
#                                                                   #
#  This was basically a quick hack to satisfy a local need.         # 
#                                                                   # 
#  No guarantees are made about this software or its usability for  # 
#  anything whatsoever.  Caveat cliens.                             # 
# ------------------------------------------------------------------# 

require ("ctime.pl");

($newserverprefix, $port) = @ARGV;
$port = 80 unless $port;

$AF_INET = 2;
$SOCK_STREAM = 1;

$sockaddr = 'S n a4 x8';

($name, $aliases, $proto) = getprotobyname('tcp');
if ($port !~ /^\d+$/) {
    ($name, $aliases, $port) = getservbyport($port, 'tcp');
}


$this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");

select(NS); $| = 1; select(stdout);

socket(S, $AF_INET, $SOCK_STREAM, $proto) || die "socket: $!";
bind(S,$this) || die "bind: $!";
listen(S,5) || die "connect: $!";

select(S); $| = 1; select(stdout);

$SIG{'INT'}  = 'cleanup';
$SIG{'CHLD'} = 'purge_children';

$con = 0;
for(;;) {
    ($addr = accept(NS,S)) || die $!;

    $con++;
    if (($child[$con] = fork()) == 0) {
	$SIG{'INT'} = 'DEFAULT';
	($af,$port,$hostaddr) = unpack($sockaddr,$addr);
	$_=<NS>;
	($operation, $url, $protocol) = split;
	select(NS);
	&respond($url);
	close(NS);
	exit;
    }
    close(NS);

}


# ------------------------------------------------------------------# 
#  Cleanup                                                          # 
#                                                                   # 
#  A basic clean up function that just closes the socket.           # 
# ------------------------------------------------------------------# 

sub cleanup {
    close(S);
}


# ------------------------------------------------------------------# 
#  Purge_Children                                                   # 
#                                                                   # 
#  Cleans up defunct children.                                      #
# ------------------------------------------------------------------# 

sub purge_children {
    wait;
}


# ------------------------------------------------------------------# 
#  Respond                                                          # 
#                                                                   # 
#  Generates the response to the request.  Please leave the first   # 
#  four lines intact, but feel free to play with the others to      #
#  customize the behavior.                                          # 
#                                                                   # 
#  If you want to force the user to see the message, change the     # 
#  "301" in line 1 to "200".                                        # 
# ------------------------------------------------------------------# 


sub respond {
    print "HTTP/1.0 301 Moved\n";
    print "Server: Redirector, 1.0a\nMIME-version: 1.0\n";
    print "Location: $newserverprefix$url\n";
    print "Content-type: text/html\n<html>\n<head>\n";
    print "<title>Server Moved</title>\n</head>\n";
    print "<body>\n<h1>Server Moved</h1>\n";
    print "<p>This document now lives ";
    print "<a href=\"$newserverprefix$url\">here</a>.</p>\n";
    print "</body>\n</html>\n";
}