#!/usr/bin/env perl
print <<EOF;
copperweb init 0.1a: A/UX - UNIX - Mac OS X
(c)opyright 2011 cameron kaiser, all rights reserved.
BSD license.


EOF

$SIG{"ALRM"} = "diequickly";


$sockaddr = 'S n a4 x8';
$this = pack($sockaddr, 2, 8080, "\0\0\0\0");
socket(S, 2, 1, 6) || die "socket: $!";
setsockopt(S, 65535, 4, 1); # SOL_SOCKET SO_REUSEADDR
bind(S, $this) || die "bind: $!";
listen(S, 5) || die "listen: $!";
select(STDOUT); $|=1;
print "bound\n";


# accept incoming calls
for (;;) {
    print "ready!\n";
    ($addr=accept(NS,S)) || die "accept: $!";
    print "connected!\n";
    select(NS); $|=1;
    $/ = "\012";

	$rin = $win = $ein = '';
	vec($rin, fileno(NS), 1) = 1;
	$win = $ein = $rin;

    $_=<NS>;
    $req = '';
    ($method, $url, $proto) = split;
    $no_host_needed = 0;
    if ($proto) {
	while (<NS>) { 
		print STDOUT "got: $_\n";
		next if (/^Connection:/i);
	    	/^Content-Length: (\S*)/i && ($content_length=$1);
		/^Host: / && ($no_host_needed = 1);
		$req .= $_;
	    	last if ($_ eq "\015\012" || $_ eq "\012");
	}
    } else {
	$proto = "HTTP/0.9";
    }
    print STDOUT "request for $method $url $proto\n";
    if ($content_length) {
	read(NS, $k, $content_length);
	$req .= $k;
	$k = '';
    }

	if ($url !~ m#^http://#) {
		print STDOUT "attempt to access as server: $url\n";
		&error("This functionality is coming SOON.\n");
		goto DIE;
	}
        ($url =~
        m#^(http)://([^:/]+):(\d+)/(.*)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, $3, "/$4"));
        ($url =~
        m#^(http)://([^:/]+):(\d+)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, $3, '/'));
        ($url =~
        m#^(http)://([^:/]+)/(.*)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, 80, "/$3"));
        ($url =~
        m#^(http)://([^:/]+)$#i) &&
                (($uproto, $them, $port, $page) = ($1, $2, 80, '/'));

	shutdown(NS, 0);
	print STDOUT "attempting connection\n";

	($name, $aliases, $type, $len, $thataddr) = gethostbyname($them);
	if (!$thataddr)  {
		print STDOUT "no such host: $them\n";
		&error("No hostname found for host $them.\n");
		goto DIE;
	}
	$that = pack($sockaddr, 2, $port, $thataddr, 0);
	socket(T, 2, 1, 6) || print STDOUT "hmm!: $!\n";
	setsockopt(T, 65535, 4101, pack("LL", 15, 0)) ||
	print STDOUT ("can't set socket timeout: this socket may hang\n");
	setsockopt(T, 65535, 4102, pack("LL", 15, 0)) ||
	print STDOUT ("can't set socket timeout: this socket may hang\n");

	eval 'alarm 15; connect(T, $that) || die($!);'; alarm 0;
	if ($@) {
		print STDOUT "connection failed: $@\n";
		&error("Could not connect to host $them.\n");
		goto DIE;
	}
	select(T); $|++;
	print STDOUT "connected to $them\n";
	$x = "$method $page HTTP/1.0\015\012" .
		"X-Proxy: Copperweb\015\012" .
		"Connection: close\015\012" .
		(($no_host_needed) ? '' : "Host: $them\015\012") .
		"$req";
	print STDOUT $x;
	print T $x;
	$content_type = '';
	$content_length = 0;
	$req = '';
	$nclreq = '';
	HEADS: while(<T>) {
		if (/^Content-type: (\S+)/i) {
			$content_type = $1;
			$content_type =~ s/;.+$//;
			$req .= "Content-type: $content_type\015\012";
			$nclreq .= "Content-type: $content_type\015\012";
			next HEADS;
		}
		if (/^Content-length: (\S+)/i) {
			$req .= $_;
			next HEADS;
		}
		$req .= $_;
		$nclreq .= $_;
		last if ($_ eq "\015\012" || $_ eq "\012");
	}
	$nbuf = '';
	$gbuf = '';
	if (&lca($content_type) ne "text/html") {
		print STDOUT $req;
		print NS $req;
		print STDOUT "not translating content type $content_type\n";
		while(<T>) {
			&transmit($_);
		}
	} else {
		print STDOUT $nclreq;
		print NS $nclreq;
		print STDOUT "translating content type $content_type\n";
		$/ = ">";
		$stop = 0;
		$bytes = 0;
		while(<T>) {
			$bytes += length;
			print STDOUT "read $bytes bytes\n";
			if (!$stop && !/<script|<style|\sstyle|^style|<iframe|onload|onclick|onmouse|onsubmit|onunload|onchange/i) {
				print NS $_;
				next;
			}
			if (!$stop) {
				$stop = 1;
				print STDOUT "screen failed, queuing for postprocessing\n";
			}
			$nbuf .= $_;
		}
		if (!length($nbuf)) {
			print STDOUT "yay, no postprocessing needed!\n";
			goto DIE;
		}
		print STDOUT "processing\n";

# this has to be REALLY, REALLY fast.
$eof = 0;
$next = '';
$exclude = '';
TOKEN: while (!$eof) {
	$buf = $next;
        $noclude = length($exclude);
        $intag = ($noclude) ? 0 : ($buf eq '<') ? 1 : 0;
	$next = "";
	$eof = 1;
        TAG: while(length($nbuf)) {
		($k, $nbuf) = unpack("aa*", $nbuf);
                if ($intag && $k eq '>') {
                        if (substr($buf, 0, 4) eq "<!--" &&
                                        $buf !~ /--$/) {
                                $buf .= ">";
                                next TAG;
                        }
			$buf = $buf . $k;
			$next = "";
			$eof = 0;
			last TAG;
                } elsif (!$intag && $k eq '<') {
                        if (!length($buf)) {
                                $buf = $k;
                                $intag = ($noclude) ? 0 : 1;
                                next TAG;
                        }
			$next = "<";
			$eof = 0;
			last TAG;
                } else {
                        $k = " " if (($k eq "\n" || $k eq "\r")
                                && $intag && $buf !~ /\s+$/);
                        $buf .= $k;
                }
        }
	print STDOUT ".";
	if (unpack("a", $buf) ne '<' && !$noclude) {
		&transmit($buf);
		next TOKEN;
	}
        $tbuf = $buf;
	$tbuf =~ tr/A-Z/a-z/;
        if ($noclude) {
                $tbuf =~ s/\s//g if ($tbuf ne $exclude);
                if ($tbuf eq $exclude) {
                        $exclude = '';
                        next TOKEN;
                }
	} elsif (unpack("a7", $tbuf) eq '<script') {
                $exclude = "</script>";
                next TOKEN;
        } elsif (unpack("a7", $tbuf) eq '<iframe') {
                $exclude = "</iframe>";
                next TOKEN;
        } elsif (unpack("a6", $tbuf) eq '<style') {
                $exclude = "</style>";
                next TOKEN;
        } elsif (unpack("a", $tbuf) eq '<' && length($buf) > 10) {
                foreach $j
('style', 'onload', 'onclick', 'onmouseover', 'onmouseout', 'onsubmit', 'onunloa
d', 'onchange')
                        {
                        1 while $buf =~ s/\s+$j\s*=\s*[^"\s]+\s+/ /i;
                        1 while $buf =~ s/\s+$j\s*=\s*[^"\s]+>/>/i;
                        1 while $buf =~ s/\s+$j\s*=\s*"[^"]+"\s+/ /i;
                        1 while $buf =~ s/\s+$j\s*=\s*"[^"]+">/>/i;
                        1 while $buf =~ s/\s+$j\s*=\s*'[^']+'\s+/ /i;
                        1 while $buf =~ s/\s+$j\s*=\s*'[^']+'>/>/i;
                }
		&transmit($buf);
        } else {
		&transmit($buf);
        }
}

	}
	print NS $gbuf;

DIE:
	$gbuf = '';
	$nbuf = '';
	close(T);

	close(NS);
    
	select(STDOUT); $|=1;
	print "end of request\n";
}

sub error {
        $buf = shift(@_);
	print NS "HTTP/1.0 500 Well, Phooey\015\012";
	print NS "Content-type: text/html\015\012";
	print NS "\015\012";
	print NS "<html><body><h1>Copperweb Fail</h1><p>$buf</p></body></html>";
}

sub diequickly { die("timeout connect"); }

sub nexttoken {
        $buf = shift(@_);
}

# Perl 4 lacks lc()
sub lca { 
        local($k) = shift(@_);
	$k =~ tr/A-Z/a-z/;
	return $k;
}

sub transmit {
	$gbuf .= shift(@_);
	return if (length($gbuf) < 256);
	print STDOUT "transmitting ".length($gbuf)." bytes to client\n";
	print NS $gbuf;
	$gbuf = '';
}