#!/usr/bin/perl -w -T
# Copyright © 2008 Jamie Zawinski <jwz@jwz.org>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# This is a null proxy.  It allows old web browsers (e.g., Netscape 0.9)
# to communicate with modern web servers by inserting the missing "Host:"
# header.
#
# Explanation: http://jwz.org/b/DRKp
#
# Usage:
#
#   - sudo cpan Net::Server::Fork
#   - ./http10proxy.pl &
#   - Set the old browser's HTTP proxy settings to localhost port 8228.
#   - Retrocompute!
#
# Created:  7-Feb-2008.

require 5;
use diagnostics;
use strict;

package HTTP10Proxy;

use vars qw(@ISA);
use Net::Server::Fork;
@ISA = qw(Net::Server::Fork);

use Socket;
require POSIX;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.4 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

HTTP10Proxy->run( port  => 8228,
                  user  => 'nobody',
                  group => 'nobody',
);
exit 0;

sub process_request($) {
  my ($self) = $@;
  eval {
    local $SIG{ALRM} = sub { die "Timed Out!\n" };
    my $timeout = 120;        # give the client 120 seconds to finish

    my $previous_alarm = alarm($timeout);
    proxy();
    alarm($previous_alarm);
  };

  if ($@ =~ m/timed out/i) {
    print STDERR "$progname: client timed out.\n";
  }
}


sub error($) {
  my ($err) = @_;
  print STDOUT "Content-Type: text/plain\n\n$err\n";
  exit 1;
}


sub proxy() {

  my $buf = '';
  my $bufsiz = 10240;

  sysread (STDIN, $buf, $bufsiz);    # Read first buffer from client
  my $http_line;

  ($http_line, $buf) = ($buf =~ m/^([^\r\n]*\r?\n)(.*)$/s);

  error ("EOF") unless $http_line;
  my ($method, $url, $version) = 
    ($http_line =~ m@^([A-Z]+)\s+(.*?)\s*(HTTP/[\d.]+)?\s*$@si);
  error ("unparsable: $http_line") unless $url;

  my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
  $path = "" unless $path;

  my ($them,$port) = split(/:/, $serverstring);
  $port = 80 unless $port;

  my $them2 = $them;
  my $port2 = $port;

  my ($remote, $iaddr, $paddr, $proto, $line);
  $remote = $them2;
  if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
  if (!$port2) {
    error ("unrecognised port in $url");
  }

  $iaddr = inet_aton($remote);
  if (!$iaddr) {
    error ("host not found: $remote");
  }

  $paddr = sockaddr_in($port2, $iaddr);
  $proto = getprotobyname('tcp');
  if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
    error ("socket: $!");
  }
  if (!connect(S, $paddr)) {
    error ("connect($serverstring): $!");
  }

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

  syswrite (S,
            "$method /$path HTTP/1.0\r\n" .
            "Host: $them\r\n");

  # If there's an existing Host header, lose it.  It confuses Apache 2.2.2.
  # (Assumes "Host" appears in the first $bufsiz bytes, and in the client's
  # first write(), both of which are probably safe assumptions...)
  # 
  # Oh, and lose that Keep-Alive crap too.

  1 while ($buf =~ s/^(Host|Connection|Proxy-Connection):.*?\n//gmi);

  syswrite (S, $buf);		# write modified first buffer to server

  while (1) {			# loop for EOF from server or client
    my $rin = '';
    vec ($rin, fileno (STDIN),  1) = 1;
    vec ($rin, fileno (S),      1) = 1;
    my $found = select ($rin, undef, undef, undef);
    last if ($found <= 0);

    if (vec ($rin, fileno (STDIN), 1)) {	# write client data to server
      my $buf = '';
      my $size = sysread (STDIN, $buf, $bufsiz);
      last if (!defined($size) || $size <= 0);
      syswrite (S, $buf);
    }
    if (vec ($rin, fileno (S), 1)) {		# write server data to client
      my $buf = '';
      my $size = sysread (S, $buf, $bufsiz);
      last if (!defined($size) || $size <= 0);

      # Convert screwy newfangled content-types, since old browsers
      # didn't know what to make of the trailing "charset" parameter.
      # Yes, this will mangle it in the document body too, if the
      # document is bigger than $bufsiz.  Sue me.
      #
      $buf =~ s@^(Content-Type:)\s+(text/(x?html|xml)|application/xhtml\+xml).*$@$1 text/html@mi;

      syswrite (STDOUT, $buf);
    }
  }

  close S;
}

1;