#!/usr/bin/perl -w
#
# Release: 20090301 -> Sun Oct 10 20:29:36 EST 2010 (except some bigpond decor)
#
# See the home page at:
#	http://adzapper.sourceforge.net/
# and the freshmeat record at:
#	http://freshmeat.net/projects/squid_redirect/
#
# Recode of the ad-zapper in perl.
# Only necessary because the shell seems to be failing big case statements.
# However, things are neater this way anyway because perl will build
# big optimised pattern matches.
#	- Cameron Simpson <cs@zip.com.au> 09apr1999
#
# Tunable policy by setting $STUBURL_xx to PASS.
#	- Cameron Simpson <cs@zip.com.au> 28jul1999
#
# Tunable CLEAR/VISIBLE mode by setting ZAP_MODE.
#	- Cameron Simpson <cs@zip.com.au> 26feb2000
#
# Personal zap pattern support.
#	- Cameron Simpson <cs@zip.com.au> 05mar2000
#
# Standalone proxy mode.
#	- Cameron Simpson <cs@zip.com.au> 02may2004
#

use strict qw(vars);
use bytes;

use POSIX ":sys_wait_h";
use Socket;
use IO::Handle;

$::IOSIZE=1024;

sub mkzapcode($);
sub mkredirectfn($);
sub proxy_forkchild($$$);
sub proxy_getheaders($);
sub proxy_lookup($);
sub proxy_main($$;$);
sub proxy_munge($$);
sub proxy_rigsocket($);
sub proxy_copybody($$$$$);

$::cmd=$0;

# restart hook
$SIG{HUP}=sub { exec($0,@ARGV) };

# what to do if we don't change anything - Johannes Berg <johannes@sipsolutions.net>
$::NoChangeValue=( defined $ENV{ZAP_NO_CHANGE} ? $ENV{ZAP_NO_CHANGE} : '' );

# where to find the replacement URLs
$::StubBase=( defined $ENV{ZAP_BASE} && length $ENV{ZAP_BASE}
	    ? $ENV{ZAP_BASE}
	    : 'http://adzapper.sourceforge.net/zaps'
	    );
# not actually useful, because SSL doesn't go via the proxy
$::SSLStubBase=( defined $ENV{ZAP_BASE_SSL} && length $ENV{ZAP_BASE_SSL}
	       ? $ENV{ZAP_BASE_SSL}
	       : 'https://adzapper.sourceforge.net/zaps'
	       );
$::SSLStubBase =~ s/^http:/https:/;	# in case

# we always zap ads, web bugs and counters so set default placeholders
$::StubURLs{NOZAP}=1;		# http://noads/ bypasses the zapper
$::StubURLs{AD}="$::StubBase/ad.gif";
$::StubURLs{ADSSL}="$::SSLStubBase/ad.gif";
$::StubURLs{ADBG}="$::StubBase/adbg.gif";
$::StubURLs{ADPOPUP}="$::StubBase/closepopup.html";
$::StubURLs{ADJS}="$::StubBase/no-op.js";
$::StubURLs{ADHTML}="$::StubBase/no-op.html";
$::StubURLs{COUNTER}="$::StubBase/counter.gif";
$::StubURLs{COUNTERJS}="$::StubBase/no-op-counter.js";
$::StubURLs{COUNTERHTML}="$::StubBase/no-op-counter.html";
$::StubURLs{WEBBUG}="$::StubBase/webbug.gif";
$::StubURLs{WEBBUGJS}="$::StubBase/webbug.js";
$::StubURLs{WEBBUGHTML}="$::StubBase/webbug.html";
$::StubURLs{ADMP3}="$::StubBase/ad.mp3";
$::StubURLs{ADSWF}="$::StubBase/ad.swf";
$::StubURLs{PRINT}=IGNORE;	# PRINT rules disabled by default
$::StubURLs{REWRITE}=1;		# typeless rewrite
$::StubURLs{ANTICRACK}=$::StubURLs{AD};	# vehicles for crackers
$::StubURLs{ADHTMLTEXT}=$::StubURLs{ADHTML};
$::StubURLs{ADJSTEXT}=$::StubURLs{ADJS};

# make use of the qr() syntax to precompile pattern REs?
# I'd do this based on perl version if I could find out when it came in...
$::UseQR=0;
if (defined $ENV{ZAP_USE_QR} && length($ENV{ZAP_USE_QR}))
{ $::UseQR=1;
}
@::ZapRE=();

# backwards compatible
if (defined $ENV{STUBURL} && length $ENV{STUBURL}
 && ! defined $ENV{STUBURL_AD})
{ $ENV{STUBURL_AD}=$ENV{STUBURL};
}

# arrange paths for the active zap classes
{ my @classes = grep(/^STUBURL_/, keys %ENV);
  for (@classes)
  { $_ =~ s/^STUBURL_//;
  }

  for my $class (@classes)
  { $::StubURLs{$class}=$ENV{"STUBURL_$class"}
	if defined $ENV{"STUBURL_$class"}
	&& length  $ENV{"STUBURL_$class"}
	;
  }
}

# use the "clear" versions if ZAP_MODE is "CLEAR"
if (defined $ENV{ZAP_MODE} && $ENV{ZAP_MODE} eq CLEAR)
{ for my $type (keys %::StubURLs)
  { $::StubURLs{$type} =~ s/\.[^.]+$/-clear$&/;
  }
}

# "generate perl" mode
if (@ARGV == 2 && $ARGV[0] eq '--generate')
{ my $ptnfile=$ARGV[1];
  if ($ptnfile eq '-')
  {}
  elsif (! open(STDIN,"< $ptnfile\0"))
  { die "$::cmd: can't open $ptnfile: $!\n";
  }

  print mkzapcode(STDIN);
  exit 0;
}

$::Verbose=0;
$::DoProxy='';
undef $::LogFile;
if (exists $ENV{ZAP_LOGFILE} && length($ENV{ZAP_LOGFILE}))
{ $::LogFile=$ENV{ZAP_LOGFILE};
}

GETOPT:
while (@ARGV)
{ if ($ARGV[0] eq '-v')
  { $::Verbose=1;
    shift(@ARGV);
  }
  elsif ($ARGV[0] eq '-P')
  { shift(@ARGV);
    $::DoProxy=shift(@ARGV);
  }
  elsif ($ARGV[0] eq '-l')
  { shift(@ARGV);
    $::LogFile=shift(@ARGV);
  }
  elsif ($ARGV[0] =~ /^-./)
  { die "$::cmd: unsupported command like option: $ARGV[0]\n";
  }
  else
  { last GETOPT;
  }
}

if (defined $::LogFile)
{ open(LOGFILE,">> $::LogFile\0")
    || die "$::cmd: can't append to $::LogFile: $!\n";
}

# Note: the $ZAP_CHAINING variable is obsolete.
#       It was originally intented for piping redirectors
#	together, but that simply doesn't work right because
#	of the protocol specification.
#	Instead, use the wrapzap script.
$::Chaining = ( exists $ENV{ZAP_CHAINING} && length $ENV{ZAP_CHAINING}
	      ? $ENV{ZAP_CHAINING} eq 'FULL'
		? 2
		: 1
	      : 0
	      );

undef $::PreMatch;
if (defined $ENV{ZAP_PREMATCH} && -s $ENV{ZAP_PREMATCH})
{ if (open(PTNS,"< $ENV{ZAP_PREMATCH}\0"))
  { $::PreMatch=mkredirectfn(PTNS);
    close(PTNS);
  }
  else
  { warn "$::cmd: can't open \$ZAP_PREMATCH ($ENV{ZAP_PREMATCH}: $!";
  }
}

if (defined $ENV{ZAP_MATCH} && -s $ENV{ZAP_MATCH})
{ if (open(PTNS,"< $ENV{ZAP_MATCH}\0"))
  { $::Redirect=mkredirectfn(PTNS);
    close(PTNS);
  }
  else
  { warn "$::cmd: can't open \$ZAP_MATCH ($ENV{ZAP_MATCH}: $!";
  }
}
else
{ $::Redirect=mkredirectfn(DATA);
}

undef $::PostMatch;
if (defined $ENV{ZAP_POSTMATCH} && -s $ENV{ZAP_POSTMATCH})
{ if (open(PTNS,"< $ENV{ZAP_POSTMATCH}\0"))
  { $::PostMatch=mkredirectfn(PTNS);
    close(PTNS);
  }
  else
  { warn "$::cmd: can't open \$ZAP_POSTMATCH ($ENV{ZAP_POSTMATCH}: $!";
  }
}

# -P lport:rproxy:rport
if (length $::DoProxy)
{ if ($::DoProxy =~ /^((\d+):)?([^:]+):([^:]+)$/)
  { my($lport,$rproxy,$rport)=($2,$3,$4);
    $lport=8080 if ! length $lport;
    warn "proxy_main($lport,\"$rproxy:$rport\",5) ...";
    proxy_main($lport,"$rproxy:$rport",5);
  }

  exit 0;
}

while (defined ($_=<STDIN>))
{
  if (defined $::LogFile)
  { print LOGFILE $_;
    LOGFILE->flush();;
  }
  chomp;
  
  my @words = split;

  my $ourl = $words[0];
  my $nurl = '';	# gets set on a redirection

  if (@words == 1 || $words[3] eq GET)
  { $nurl=redirect(@words);
  }

  if (! $::Chaining)
  { print "$nurl\n";
  }
  else
  { $nurl=$ourl if ! length $nurl;

    if ($::Chaining == 1)
    { print "$nurl\n";
    }
    else
    { print "$nurl @words[1..$#words]\n";
    }
  }

  STDOUT->flush();
}

exit 0;

# We need to deal correctly with whitespace and %xx stuff.
# Report from Rod Savard 29mar2004.
sub unpcnt($)
{ my($txt)=@_;
  $txt =~ s/%([0-9a-f][0-9a-f])/eval "chr(0x$1)"/eg;
  return $txt;
}

sub pcnt($)
{ my($txt)=@_;
  ##my $otxt = $txt;
  $txt =~ s/[\s'"\000-\031\177-\377]/sprintf("%%%02x",ord($&))/eg;
  ##warn "<= $otxt\n=> $txt\n";
  return $txt;
}

sub redirect
{ my(@words)=@_;

  my $nurl='';

  if (defined $::PreMatch)
  { $nurl=&$::PreMatch(@words);
  }
  if (! length $nurl)
  { $nurl=&$::Redirect(@words);
  }
  if ( ! length $nurl && defined $::PostMatch)
  { $nurl=&$::PostMatch(@words);
  }
  if ( ! length $nurl )
  { $nurl=$::NoChangeValue;
  }


  return pcnt($nurl);
}

# Read pattern specs from a stream and turn into perl code.
# Patterns are shell-style patterns, except that:
#	** matches strings including /
#	? is not a meta character
#	. isn't either
#	\ doesn't work
# - Cameron Simpson <cs@zip.com.au> 09apr1999
#

sub mkzapcode($)
{ my($STREAM)=@_;

  my $code = "y|/||s;
	      if (0) {}\n";
  my $ncode;

  my $lastclass;
  my @ptns;

  local($_);

  RULE:
  while (defined($_=<$STREAM>))
  { chomp;

    s/^\s+//;
    s/^#.*//;
    next if ! length;

    my(@F)=split;
    if (@F < 2 || @F > 3)
    { warn "$::cmd: $STREAM, line $.: wrong number of arguments\n\tneed CLASS pattern\n\tor   CLASS pattern subst\n";
      next RULE;
    }

    my($class)=shift(@F);
    $class=uc($class);

    # avert our eyes from some classes
    if ($class ne PASS
     && ( ! exists($::StubURLs{$class})
       || $::StubURLs{$class} eq IGNORE
	))
    { ##warn "skip (class=$class) $_\n";
      next RULE;
    }

    if (@F == 1)
    # plain match
    {
      my $ptn = shift(@F);

      $lastclass=$class if ! defined $lastclass;
      if ($class ne $lastclass)
      { if (@ptns)
	{ $code.=process($lastclass,@ptns);
	  @ptns=();
	}

	$lastclass=$class;
      }

      push(@ptns,$ptn);
    }
    elsif (@F == 2)
    # rewrite
    { my($ptn,$subst)=@F;

      # flush pending patterns
      if (@ptns)
      { $code.=process($lastclass,@ptns);
	@ptns=();
      }

      undef $lastclass;

      # for debugging
      my $ptndesc = "$class $ptn $subst";
      $ptndesc =~ s/['\\]/\\$&/g;

      $ptn='^'.ptn2re($ptn).'$';
      my $ptnexpr = re2expr($ptn);

      $code.="  elsif($ptnexpr)\n"
	    ."  { \$nurl=\"$subst\";\n"
	    ."    if (\$::Verbose)\n"
	    ."    { warn \"$class \$_\\non:\\n\".'$ptndesc'.\"\\n\";\n"
	    ."    }\n"
	    ."  }\n";
    }
    else
    { warn "$::cmd: $STREAM, line $.: unhandled number of fields [@F]\n\t";
    }
  }

  # flush pending patterns
  $code.=process($lastclass,@ptns) if @ptns;

  $code.="  elsif (\$::Verbose)\n"
	."  { warn \"PASS \$_ on no match\\n\";\n"
	."  }\n";

  $code;
}


sub subptn2re($)
{ local($_)=@_;
  return "[^/]*" if $_ eq '*';	# * -> [^/]*
  return ".*" if /^\*+$/;	# ** -> .*
  return $_;			# leave everything else alone
}

sub ptn2re($)
{ local($_)=@_;
  y|/||s;				# turn slashes into "/+"
  s|[.\@\%\$?+]|\\$&|g;			# quote specials
  s:(\\.|[^*\\]|\*+):subptn2re($&):eg;
  return $_;
}

sub re2expr
{ my($re)=@_;

  # old style compile-on-first-use
  return "m($re)o" if ! $::UseQR;

  # new style - force compilation now
  my $qr = eval 'qr($re)o';
  if ($@)
  { warn "$::cmd: qr fails: qr($re): $@";
    $::UseQR=0;
    return "m($re)o";
  }

  push(@::ZapRE,$qr);
  my $expr = "/\$::ZapRE[$#::ZapRE]/";
  warn "re=[ $re ]\nexpr=[ $expr ]";
  return $expr;
}

sub process
{ my($class)=shift;
  my(@ptns)=@_;

  my $nurl;

  if ($class eq PASS)
  { $nurl=PASS;
  }
  else
  # we trimmed unknown classes and IGNORE classes in mkzapcode()
  # so we can believe this without further checks
  { $nurl = $::StubURLs{$class};
  }

  my $code = '';

  # for debugging
  my $ptndesc = join("\n\t\t\t", map("$class $_", @ptns));
  $ptndesc =~ s/['\\]/\\$&/g;

  local($_);

  # transmute patterns into regexps
  @ptns=map(ptn2re($_),@ptns);

  # was joined with \n\t| but older perls don't like that
  my $bigptn = '^('.join('|', @ptns).')$';
  my $ptnexpr = re2expr($bigptn);

  $code.="  elsif ($ptnexpr)\n";
  if ($nurl eq PASS)
	{ $code.="  { \$nurl=\$url;\n"
		."    warn \"PASS \$_\\non:\\t\\t\\t\".\n\t\t\t'$ptndesc'.\"\\n\" if \$::Verbose;\n"
		."  }\n";
	}
  else	{ $code.="  { \$nurl=\$::StubURLs{$class};\n"
		."    if (\$::Verbose)\n"
		."    { warn \"$class \$_\\non:\\t\\t\\t\"\n\t\t\t.'$ptndesc'.\"\\n\";\n"
		."    }\n"
		."  }\n";
	}

  return $code;
}

sub mkredirectfn($)
{ my($STREAM)=@_;

  my $fn = 'sub { my($url,$client,$ident,$method)=@_;
		  local($_)=unpcnt($url);

		  my $nurl = "";
	   '
	 . mkzapcode($STREAM)
	 . '
		  return $nurl;
	    }';

  my $fnref;
  eval "\$fnref=$fn";
  if ($@)
  { warn "$::cmd: error compiling function: $@\n\tcode is:\n$fn\n";
    undef $fnref;
  }

  return $fnref;
}

sub proxy_term($)
{ my($sig)=@_;
  if ($$ == $::ProxyMainPid)
  {
    for my $pid (@::ProxyChildren)
    { kill($pid,15);
    }
  }
  exit 1;
}

sub proxy_main($$;$)
{ my($listen_port,$upstream,$nforks)=@_;
  $nforks=5 if ! defined $nforks;

  # nail children on abort
  @::ProxyChildren=();
  $::ProxyMainPid=$$;
  $SIG{__DIE__}=\&proxy_term;
  $SIG{HUP}=\&proxy_term;
  $SIG{INT}=\&proxy_term;
  $SIG{TERM}=\&proxy_term;

  local($::TCP_Proto)=scalar(getprotobyname('tcp'));
  ##warn "[$$]: TCP_Proto=[$::TCP_Proto]";

  my($proxy_name,$proxy_port,$proxy_addr,$proxy_paddr)
   = proxy_lookup($upstream);

  # set up token stream
  pipe(FROMCHILD, TOPARENT) || die "$::cmd: pipe: $!";

  proxy_rigsocket($listen_port);

  warn "[$$]: listening on port $listen_port ...\n";

  for my $i (1..$nforks)
  { push(@::ProxyChildren,proxy_forkchild($proxy_paddr,$proxy_name,$proxy_port));
  }

  # spawn new children as the old children die
  while (<FROMCHILD>)
  {
    # grab any dead children
    my $pid;
    while (($pid=waitpid(-1,WNOHANG)) > 0)
    { ##warn "[$$]: waitpid got something\n";
      @::ProxyChildren=grep($_ != $pid, @::ProxyChildren);
    }

    # spawn fresh child
    push(@::ProxyChildren,proxy_forkchild($proxy_paddr,$proxy_name,$proxy_port));
  }

  die "[$$]: exit from supposed main (parent is ".getppid().")";
}

sub proxy_lookup($)
{ my($upstream)=@_;

  my $proxy_name = 'proxy';
  my $proxy_port = 8080;
  my $proxy_addr;
  my $proxy_paddr;

  if ($upstream =~ /^(\S+):(\S+)$/)
  { $proxy_name=$1;
    $proxy_port=$2;
  }
  elsif (length $upstream)
  { $proxy_name=$upstream;
  }

  if ($proxy_port =~ /^\D/)
  { $proxy_port=getservbyname($proxy_port, 'tcp');
    die "$::cmd: No proxy port" unless $proxy_port;
  }

  $proxy_addr = inet_aton($proxy_name) || die "$::cmd: can't look up \"$proxy_name\"";
  $proxy_paddr = sockaddr_in($proxy_port, $proxy_addr);

  return ($proxy_name,$proxy_port,$proxy_addr,$proxy_paddr);
}

sub proxy_rigsocket($)
{ my($listen_port)=@_;
  die "$::cmd: socket: $!" if ! socket(SOCK, PF_INET, SOCK_STREAM, $::TCP_Proto);

  die "$::cmd: setsockopt: $!" if ! setsockopt(SOCK,
					SOL_SOCKET,
					SO_REUSEADDR,
					pack("l", 1));

  ##warn "[$$]: bind to port $listen_port ...";
  die "$::cmd: bind: $!" if ! bind(SOCK, sockaddr_in($listen_port, INADDR_ANY));

  die "$::cmd: listen: $!" if ! listen(SOCK,SOMAXCONN);
  ##system("netstat -an | grep $listen_port");
}

sub proxy_forkchild($$$)
{ my($proxy_paddr,$proxy_name,$proxy_port)=@_;

  my $pid;
  if (! defined ($pid=fork))
  { die "$::cmd: fork fails: $!";
  }

  # parent returns, child proceeds
  return $pid if $pid != 0;

  ##warn "[$$]: new child forked...";

  # we don't need this
  close(FROMCHILD);

  my $ok = accept(CONN,SOCK);
  die "$::cmd: accept: $!" if !$ok;
  # tell parent we need a new child
  print TOPARENT "\n";
  close(TOPARENT);
  ##warn "[$$]: new child: accepted";
  close(SOCK);	# let go of socket

  my $persist=1;
  my @hdrs;
  my $gotproxy=0;
  my($method,$uri,$v1,$v2);
  local($_);
  my $pass=0;
  my $orq;
  my $grandchild;

  REQUEST:
  while ($persist)
  {
    ++$pass;

    warn "[$$]: pass $pass: waiting for request ...\n";
    if ($pass > 1)
    { ##warn "[$$]:      last rq was $orq\n";
    }

    # read request
    if (! defined($_=<CONN>))
    { ##warn "[$$]: EOF from client, quitting\n";
      if ($gotproxy)
      { ##warn "[$$]: killing grandchild $grandchild\n";
	kill(15,$grandchild)
		|| warn "$::cmd: [$$]: kill(TERM,$grandchild): $!";
      }
      exit 0;
    }

    chomp;
    s/\r$//;
    s/\s+$//;

    if (! m:^(\S+)\s+(.*\S)\s+HTTP/0*(\d)\.0*(\d+)\s*\r?$:)
    { warn "$::cmd: bad syntax from client: $_";
      print CONN "400 Invalid HTTP request: $_\r\n";
      exit 0;
    }

    ($method,$uri,$v1,$v2)=($1,$2,$3+0,$4+0);
    $orq="$method $uri HTTP/$v1.$v2";
    warn "[$$]: pass $pass: $orq\n";

    # or depend on keep-alive? check >= 1.1
    $persist = ($v1 > 1 || ($v1 == 1 && $v2 >= 1));
    ##warn "[$$]: persist from request = [$persist]";

    # gather up the request
    @hdrs=proxy_getheaders(CONN);

    ## see if "Connection: close" supplied
    if (grep(uc($_->[0]) eq CONNECTION && $_->[1] =~ /\bclose\b/i, @hdrs))
    { $persist=0;
      ##warn "[$$]: disable persist by Connection: close";
    }

    ## munge URL here and adjust Host: if changed
    { my $muri = $uri;	# URI to munge

      # turn into absolute URL if necessary
      if ($muri !~ m|^[a-z][-a-z\d+.]*:|i)
      # no scheme - add http:// and Host
      { my @hosts = map($_->[1], grep(uc($_->[0]) eq HOST, @hdrs));
	if (@hosts)
	# yes, there is a Host: header
	{ @hosts = grep(length,split(/\s+/,$hosts[0]));
	  if (@hosts)
	  # yes, there's a host in the first Host: header
	  { $muri = "/$muri" unless $muri =~ m:^/:;
	    $muri="http://".lc($hosts[0])."$muri";
	  }
	}
      }

      my $nuri=proxy_munge($muri,$method);

      if ($nuri ne $muri)
      {
	warn "[$$]: ouri: $muri\n";
	warn "[$$]: nuri: $nuri\n";

	$uri=$nuri;

	# see if we need to change the Host: header
	if ($muri =~ m|^https?://([^@/]*@)?([^/:]+)(:[^/]*)?/|i)
	{ my $ohost=lc($2);
	  if ($nuri =~ m|^https?://([^@/]*@)?([^/]+)/|i)
	  { my $nhost=lc($2);
	    if ($nhost ne $ohost)
	    { for my $H (@hdrs)
	      { if (uc($H->[0]) eq HOST)
		{ ##warn "[$$]: $H->[0]: $H->[1] -> $nhost\n";
		  $H->[1]=" $nhost";
		}
	      }
	    }
	  }
	}
      }
    } ## end of munge

    my $proxyagain=1;

    PROXYLOOP:
    while($proxyagain)
    {
      # we general run this loop only once
      $proxyagain=0;

      # ready to go - connect to upstream server if necessary
      if (! $gotproxy)
      {
	# channel to report persistence
	# \n - persist
	# EOF - close upstream connection and refork, reconnect on next rq
	pipe(FROMGRANDCHILD, TOCHILD) || die "$::cmd: [$$]: pipe: $!";
	pipe(GCHILD_READ, GCHILD_WRITE) || die "$::cmd: [$$]: pipe: $!";

	# connection to upstream
	socket(PROXY, PF_INET, SOCK_STREAM, $::TCP_Proto)
	  || die "$::cmd: proxy socket: $!";
	connect(PROXY, $proxy_paddr)
	  || die "$::cmd: connect($proxy_name:$proxy_port): $!";

	$gotproxy=1;
	##warn "[$$]: connected to proxy\n";

	# fork child to stream proxy responses
	my $child=$$;
	$grandchild = fork();
	if ($grandchild < 0)
	{ my $err = "$!";
	  warn "$::cmd: fork: $err";
	  print CONN "503 fork: $err\r\n";
	  exit 0;
	}

	if ($grandchild == 0)
	# child - copy proxy output
	# this used to be a straight copy
	# but we must parse and honour "Connection: close"
	# from upstream
	{ proxy_grandchild($child);
	  exit 0;
	}

	# parent - fall through and handle connection
	close(TOCHILD);
	close(GCHILD_READ);
      }

      # dispatch request and headers
      print GCHILD_WRITE "$method $uri $v1 $v2\n"
	|| die "tell grandchild the request: $!";
      GCHILD_WRITE->flush();

      print PROXY "$method $uri HTTP/$v1.$v2\r\n";
      for my $H (@hdrs)
      { print PROXY $H->[0], ":", $H->[1], "\r\n";
      }
      print PROXY "\r\n";
      PROXY->flush();
      ##warn "[$$]: sent rq to proxy\n";

      proxy_copybody(CONN,PROXY,$method,$persist,\@hdrs)
	|| die "copybody up to PROXY failed: $!";

      ##warn "[$$]: end request for $uri\n";

      # read [persist response] from child
      if (!defined($_=<FROMGRANDCHILD>))
      { $gotproxy=0;
	close(FROMGRANDCHILD);
	warn "[$$]: abort from grandchild, retrying with new grandchild";
	$proxyagain=1;
	next PROXYLOOP;
      }
      chomp; s/\r$//; s/\s+$//;
      warn "[$$]: grandchild said [$_]\n";
      if (!/^([A-Z]+)\s+(\d\d\d)\s*/)
      { warn "[$$]: bad grandchild return, bailing out";
	exit 0;
      }
      my($gchoice,$gresponse,$getc)=($1,$2,$3);
      if ($gchoice eq PERSIST)
      { $persist=1;
      }
      elsif ($gchoice eq CLOSE)
      { $persist=0;
      }
      else
      { die "[$$]: unsupported choice \"$gchoice\", aborting";
      }

      warn "[$$]: loop bottom: persist=$persist";
    }	# end of PROXYLOOP
  }	# end of REQUEST $persist loop

  ##warn "[$$]: child exits";

  exit 0;
}

sub proxy_getheaders($)
{ my($conn)=@_;

  # list of [field,body] pairs
  my @hdrs=();

  local($_);

  my($f,$b);

  HEADER:
  while (defined($_=<$conn>))
  {
    # trim end of line
    chomp;
    s/\r$//;

    last HEADER if ! length;

    if (/^[ \t]/)
    # continuation
    { $b.="\r\n$_";
    }
    else
    # end of current header, start new
    {
      # stash pending header, if any
      if (defined $f)
      { ##warn "[$$]: [$f: $b]";
	push(@hdrs,[$f,$b]);
	undef $f;
	undef $b;
      }

      if (/^([^:\s]+):/)
      # new header
      { $f=$1; $b=$';
      }
      else
      { s/\s+$//;
	warn "$::cmd: bad header line: $_\n\tending header read";
	last HEADER;
      }
    }
  }

  # stash pending header, if any
  if (defined $f)
  { ##warn "[$$]: [$f: $b]";
    push(@hdrs,[$f,$b]);
    undef $f;
    undef $b;
  }

  ##warn "[$$]: got headers";
  return @hdrs;
}

sub proxy_grandchild($)
{ my($child)=@_;

  close(FROMGRANDCHILD);
  close(GCHILD_WRITE);

  select(CONN);
  $|=1;

  ##warn "[$child:$$]: grandchild, copying from proxy ...\n";

  local($_);
  my $rq;

  RESPONSE:
  while (defined($rq=<GCHILD_READ>) && defined($_=<PROXY>))
  {
    my($rq_method, $rq_uri, $rq_v1, $rq_v2)=split(/\s+/,$rq);

    # collect response line
    if (! m:^HTTP/(\d+)\.0*(\d+)\s+(\d\d\d)\s*([^\r\n]*):)
    { warn "$::cmd: [$child:$$]: bad response from proxy: $_\n";
      close(TOCHILD);
      last RESPONSE;
    }

    my($v1,$v2,$code,$info)=($1,$2,$3,$4);
    warn "[$$:$child]: [HTTP/$v1.$v2 $code $info]\n";

    # collect response headers
    my @hdrs = proxy_getheaders(PROXY);
    for my $H (@hdrs)
    { warn "  $H->[0]:$H->[1]\n";
    }

    # adjust persistence based on response code and headers

    # disable persistence for HTTP/1.0 and below by default,
    # then permit it if "Proxy-Connection: keep-alive"
    my $persist = 1;
    if ($v1 < 1 || ($v1 == 1 && $v2 < 1))
    { $persist=0; warn "[$child:$$]: disable persist - HTTP < 1.1\n";

      if (0&&grep( uc($_->[0]) eq 'PROXY-CONNECTION'
	     && $_->[1] =~ /\bkeep-alive\b/i,
		@hdrs
	      )
	 )
      { $persist=1;
	warn "[$child:$$]: enable persist by proxy's Proxy-Connection: keep-alive";
      }
    }
    else
    { warn "disable persist for HTTP/$v1.$v2 response anyway\n";
      $persist=0;
    }

    # see if "Connection: close" supplied
    # or "Proxy-Connection: close" (from Netscape-Enterprise/3.6 SP3)
    if (grep( ( uc($_->[0]) eq CONNECTION
	     || uc($_->[0]) eq "PROXY-CONNECTION"
	      ) && $_->[1] =~ /\bclose\b/i,
	     @hdrs)
       )
    { $persist=0;
      warn "[$child:$$]: disable persist by proxy's Connection: close";
    }

    warn "[$child:$$]: pass response to parent\n";
    print TOCHILD ($persist ? PERSIST : CLOSE)." $code $info"
	|| die "[$child:$$]: print(TOCHILD) fails: $!";
    TOCHILD->flush();
    warn "[$child:$$]: told parent, passing response to client\n";

    # copy to child
    print CONN "HTTP/$v1.$v2 $code $info\r\n";
    for my $H (@hdrs)
    { print CONN $H->[0], ":", $H->[1], "\r\n";
    }
    print CONN "\r\n";
    CONN->flush();

    # see RFC2616 section 10
    if (
	$rq_method ne HEAD
     && (
	  $code == 200 && grep($rq_method eq $_,GET,POST,TRACE)
       || grep($code == $_, 201,202,203,206,
			    300,301,302,303,307,
			    401,403,404,406,409)
       || $code =~ /^5/
	)
       )
    { 
      proxy_copybody(PROXY,CONN,'',$persist,\@hdrs)
	|| die "copybody from PROXY to CLIENT fails: $!";
    }

    last RESPONSE if !$persist;
    warn "[$child:$$]: getting next PROXY response...\n";
  }

  warn "[$child:$$]: exiting\n";
  exit 0;
}

sub proxy_copybody($$$$$)
{ my($from,$to,$method,$persist,$H)=@_;

  my $ok=1;
  my $err;

  warn "[$$]: copybody($from,$to,...)\n";
  ## copy the body, if any
  ## deduce length according to RFC2616 part 4.4
  my @te = grep(uc($_->[0]) eq 'TRANSFER-ENCODING', @$H);
  if (@te && uc($te[0]->[1]) ne IDENTITY)
  # expect chunked data transfer
  { my($ok,$err)=proxy_copychunked($from,$to);
  }
  else
  # expect ordinary body, possibly with Content-Length
  {
    my $cl = undef;
    my @cl = grep(uc($_->[0]) eq 'CONTENT-LENGTH', @$H);
    if (@cl)
    { $cl=$cl[0]->[1]+0;
      warn "  content-length=$cl\n";
    }
    elsif ($persist)
    { $cl=0;	# assume no body
    }

    if ($persist ? 1 : ($method ne GET && $method ne HEAD))
    # copy body using Content-Length
    { ($ok,$err)=proxy_copycl($from,$to,$cl);
    }
  }
  warn "[$$]: copybody done\n";

  return $ok;
}

sub proxy_copycl($$$)
{ my($from,$to,$cl)=@_;

  my $ok=1;

  warn "[$$]: reading unchunked body from $from";
  local($_)='';
  COPY:
  while ((!defined($cl) || $cl > 0)
      && read($from,$_,(defined $cl && $cl < $::IOSIZE ? $cl : $::IOSIZE)) > 0
	)
  {
    ##warn "[$$]: read ".length($_)." bytes of request body\n";
    $to->autoflush(1);
    if (! print $to $_)
    { warn "$::cmd: [$$]: print $to ..): $!";
      $ok=0;
      last COPY;
    }
    $to->autoflush(0);
    $cl-=length if defined $cl;
  }
  warn "[$$]: finished unchunked body, ok=$ok";

  return ($ok,"");
}
sub proxy_copychunked($$)
{ my($from,$to)=@_;

  local($_);
  my $chunksize;

  CHUNK:
  while (defined($_=<$from>))
  {
    if (! /^([\da-f]+)/)
    { return (0,"bad chunk size: $_");
    }
    $chunksize=eval("0x$1");
    print $to $_;

    last CHUNK if $chunksize == 0;
    
    $_='';
    while ($chunksize > 0 && read($from,$_,($chunksize < $::IOSIZE ? $chunksize : $::IOSIZE)) > 0)
    { print $to $_;
      $chunksize-=length;
    }
    $to->flush();
  }

  $to->flush();

  # pass trailer headers
  while (defined($_=<$from>) && !/^\r?\n/)
  { print $to $_;
  }
  if (defined)
  { ##warn "[$$]: final trailer: $_";
    print $to $_;
  }
  $to->flush();

  return (1,"");
}

sub proxy_munge($$)
{ my($uri,$method)=@_;

  my $nuri = redirect($uri,'-','-',$method);
  $uri=$nuri if length $nuri;

  return $uri;
}

__DATA__
### END AUTO __DATA__ AREA
