#!/usr/local/bin/perl

#           redirex: Redirect requests to a new Web server

#            by John Walker  --  http://www.fourmilab.ch/
#                             March 1998

#   Usage: redirex [ -p port ] [ -c configfile ] &

#   Sample invocations: 
#       redirex -p 3000 -c redirex.conf & # start on port 3000 and read redirex.conf
#       redirex -c redirex.conf &         # start on the default port use redirex.conf
#       redirex &                         # start on the default port specified by the
#                                           configuration named by the variable
#                                           $defaultConfigFile (see the source).

#   Redirex is derived from "mhttpd"--a small HTTP server written in Perl
#   Credits for mhttpd are as follows:
#
#               Author: Jerry LeVan (levan@eagle.eku.edu)
#               Date:   March 25, 1996
#               Ver:    0.1
#               Env:    Perl 5.002
#
#               Note:   This program was directly inspired by Bob Diertens simple
#                       cgi "Get" server for executables( aka bobd ). 
#                       Bob's Address: <bobd@fwi.uva.nl> URL: http://www.fwi.uva.nl/~bobd/ 
#                       Another source of inspiration was Pratap Pereira's phttpd, Prataps
#                       address http://eewww.eng.ohio-state.edu/~pereira". I have shamelessly
#                       "borrowed" code from these two programs. They are entirely blameless
#                       for any flaws in this code.
#               WARNING:
#                     I take no responsibility for any problems arising from the use
#                     of this code. I have taken all of the steps that I know of to
#                     ensure the reliability and security of the data that this program
#                     can access, regretably there are many more persons that are much
#                     more clever than I prowling the Net. If you find a security hole
#                     please tell me, and I would greatly appreciate any hole plugging
#                     infomation that you can provide.

#   Redirex is a much simpler application than mhttpd, so much of the
#   code in the original program has been deleted in creating this
#   single-purpose redirector.  Naturally, any errors and omissions
#   in this program are entirely the responsibility of John Walker,
#   who hacked it into existence.

    $program = 'redirex';
    $version = '1.1';

    require 'getopt.pl';

    #   If the following variable is defined and the -c option is
    #   not used, then $defaultConfigFile will be used.

    $defaultConfigFile = "$program.conf";

    &Getopt('pc');
    $port = $opt_p if defined $opt_p;

    $opt_c = $defaultConfigFile if defined($defaultConfigFile) && !defined($opt_c);

    print ("No Configuration file specified!\n"), exit(1) unless defined $opt_c;

    require $opt_c;                   # Include configuration file

    open(LOG,">>$logfile") || die "Can't open log file";
    #   Set log file unbuffered
    select(LOG); $| = 1; select(STDOUT);

    $port = $defaultport unless defined $port;

    $login = getlogin || (getpwuid($<))[0] || "Intruder!"; 
    $0 = "$program($login:$port)";  # new name for the "ps" program

    # Set up SIG vector

    $SIG{'CHLD'} = 'reaper';
    $SIG{'KILL'} = "SigHandler";
    $SIG{'INT'} = "SigHandler";
    $SIG{'TERM'} = "SigHandler";
    $SIG{'QUIT'} = "SigHandler";
    $SIG{'HUP'} = "SigHandler";

    # Initialise port

    @ipcomp = split(/\./, $IPlisten);
    $justListen = 'S n C4 x8';
    $sockaddr = 'S n a4 x8';
    ($name, $aliases, $proto) = getprotobyname('tcp');
    $thisport = pack($justListen, $AF_INET, $port, @ipcomp);

    socket(S, $PF_INET, $SOCK_STREAM, $proto)
                            || die "can't create $name $proto socket: $!\n";
    setsockopt(S, $SOL_SOCKET, $SO_REUSEADDR, pack('i', 1))
                            || die "can't setsockopt: $!\n";
    bind(S, $thisport)      || die "can't bind socket: $!\n";
    listen(S, 5)            || die "can't listen to socket: $!\n";


    &logInfo("Starting $program $version on port $port");

    # Answer if someone knocks on the port.

    for (;;) {
      
      if (!accept(NS, S)) {
         if ($! == $EINTR || $! == $ECHILD || $! == $EPROTO) {
            next;
         }
         &logInfo("Accept Failure, shutting down $program, error: $!");
         exit(1);
      }

      if (($child = fork()) == 0) {

            # This is the child process

            # Get the method and command

            ($method, $command) = &SetupCommand(NS); 

            if ($method eq 'GET' || $method eq 'POST'){
                &SendRedirect(NS, $command, 1);
            } elsif ($method eq 'HEAD') {
                &SendRedirect(NS, $command, 0);
            } else {
                &ErrorMessage(NS, 400, "Bad Request.");
            }
            exit(0);
        } else {
            close NS;
        }
    }

    # Grab a line without using buffered input... Important for
    # POST methods since they have to read the stream.

    sub readline {
        local($fd) = $_[0];
        local($ch);
        local($string) = '';

        alarm 120;   # prevent deadly spin if other end goes away
        for (;;) {
            if (sysread($fd,$ch,1)) { # returns undef or 1
                $string .= $ch unless $ch eq "\r"; # skip <cr>
                last if $ch eq "\n";
            }
        }
        alarm 0;    # clear alarm
        return $string;
    }

    # Sets many environmental variables, processes prolog from client
    # and returns $method and $command to main loop

    sub SetupCommand {
        local($sock) = $_[0];
        local($inp);
        local($method, $command);
        local($rem_ip_addr, $radr);

        #   Get first line from client
        $inp = &readline($sock);
        $inp =~ s/\s+$//;

        $inp =~ /^([A-Z]*) \/(.*) (\w*)\/(\d*\.\d*)/;
        # We should check if the match failed!

        $method = $1;
        local($commandline) = $2;
        local($protocol) = $3;
        local($protocol_version) = $4;

        $command = $commandline;
        $rem_ip_addr = (unpack($sockaddr, getpeername($sock)))[2];
        $radr = join(".", unpack("C4", $rem_ip_addr));
        $logitem = &timestamp();
        $logitem = "$radr - - $logitem \"$inp\"";

        $requestingHost = '';
        for (;;) { # read until we get a blank line
            $string = &readline($sock);
            $string =~ s/\s+$//;
            last if $string eq "";
            if ($string =~ /Host:/i) {
                $requestingHost = (split(" ", $string))[1];
            }
        }
        return ($method, $command);
    }

    # Print an error message to the client

    sub ErrorMessage {
        local($fd, $error, $message) = @_;

        print $fd  "HTTP/1.0 501 Not Implemented\r\n";
        print $fd  "Content-type: text/html\r\n\r\n";
        print $fd "<html>\n<head>\n<title>Error Message</title>\n</head>\n<body>\n";
        print $fd "<h1>Error $error</h1>\n";
        print $fd "<hr>\n";
        print $fd "$message\n";
        print $fd "<hr>\n</body>\n</html>\n";
        close($fd);
        print LOG "$logitem 501 512\n";
    }

    #   Send redirect document including remapped request to user.

    sub SendRedirect {
        local($fd, $url, $body) = @_;
        local($uu, $listat);

        if ($DOredirect) {
            print $fd "HTTP/1.0 301 Moved Permanently\r\n";
            print $fd "Location: $newServer/$url\r\n";
            $listat = 301;
        } else {
            print $fd "HTTP/1.0 200 OK\r\n";
            $listat = 200;
        }
        print $fd  "Content-type: text/html\r\n\r\n";
        if ($body) {
            print $fd "<html>\n<head>\n<title>Obsolete Server Specified</title>\n</head>\n<body>\n";
            print $fd "<h1>Obsolete Server Specified</h1>";
            print $fd "<hr>\n";
            print $fd "The document you requested:<p>\n";
            $uu = '';
            if ($requestingHost ne '') {
               $uu = "http://$requestingHost";
            }
            print $fd "<center>$uu/$url</center><p>\n";
            print $fd "is no longer on this Web server.  Please try\n";
            print $fd "the current server:<p>\n";
            print $fd "<center><a href=\"$newServer/$url\">$newServer/$url</a></center><p>\n";
            print $fd "and inform the owner of this page to update the\n";
            print $fd "link to point to the new server.<p>Thank you.\n";
            print $fd "<h3><a href=\"$newHomePage\">$newHomePageDescription</a></h3>\n";
            print $fd "<p>\n<hr>\n</body>\n</html>\n";
        }
        close($fd);
        print LOG "$logitem $listat 512\n";
    }

    #   Generate a time stamp in NCSA common log file format

    sub timestamp {
        local($t) = time();
        local(@months) = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
                           "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
        local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($t);
        local($umin, $uhour) = (gmtime($t))[1..2];
        local($dt, $dts);

        $dt = (($hour * 60) + $min) - (($uhour * 60) + $umin);
        while ($dt >= 24 * 60) {
            $dt -= 24 * 60;
        }
        while ($dt <= -24 * 60) {
            $dt += 24 * 60;
        }

        if ($dt < 0) {
            $dt = -$dt;
            $dts = '-';
        } else {
            $dts = '+';
        }
        $dt = $dts . sprintf("%02d%02d", int($dt / 60), $dt % 60);
        sprintf("[%02u/%s/%04u:%02u:%02u:%02u %+05d]",$mday, $months[$mon], $year + 1900,
                $hour, $min, $sec, $dt);
    }

    #   Add an INFO item to the log

    sub logInfo {
        local($msg) = $_[0];
        local($ip_addr, $sadr, $infoitem);

        $ip_addr = (unpack($sockaddr, getsockname(S)))[2];
        $sadr = join(".", unpack("C4", $ip_addr));

        #   If $IPlisten is 0.0.0.0, and hence we're listening on
        #   any port, attempt to obtain the primary IP address of the
        #   host on which we're running and use that for the
        #   informational log entry.

        if ($sadr =~ m/^0\./) {
            local(@ip_adds);

            $sadr = `hostname`;
            $sadr =~ s/\s+$//;
            @ip_adds = (gethostbyname($sadr))[4];
            $ip_addr = $ip_adds[0];
            $sadr = join(".", unpack("C4", $ip_addr));
        }
        $infoitem = &timestamp();
        $infoitem = "$sadr - - $infoitem \"INFO $program: $msg\" 204 0\n";
        print LOG $infoitem;
    }

    #   Interrupt handler for shutting down

    sub SigHandler {
        local($sig) = $_[0];
        &logInfo("Caught signal SIG$sig, $program shutting down.");
        exit(1);
    }

    #   Reap child processes

    sub reaper {
        while (1) {
            $pid = waitpid(-1, $WNOHANG);
            last if ($pid < 1);
        }
        $SIG{'CHLD'} = 'reaper';      # Reset child process reaper
    }
