#!/usr/local/bin/perl -w
use strict;
$ENV{PATH} = join ":", qw(/usr/ucb /bin /usr/bin);
$|++;

## Copyright (c) 1996 by Randal L. Schwartz
## This program is free software; you can redistribute it
## and/or modify it under the same terms as Perl itself.

## Anonymous HTTP proxy (handles http:, gopher:, ftp:)
## requires LWP 5.04 or later

## Modified on 02/19/2002 by Stephane Gigandet
## Added support for macros.

my $HOST = "localhost";
my $PORT = "8008";

sub prefix {
  my $now = localtime;

  join "", map { "[$now] [${$}] $_\n" } split /\n/, join "", @_;
}

$SIG{__WARN__} = sub { warn prefix @_ };
$SIG{__DIE__} = sub { die prefix @_ };
$SIG{CLD} = $SIG{CHLD} = sub { wait; };

my $AGENT;                      # global user agent (for efficiency)
BEGIN {
  use LWP::UserAgent;

  @MyAgent::ISA = qw(LWP::UserAgent); # set inheritance

  $AGENT = MyAgent->new;
  $AGENT->agent("anon/0.07");
  $AGENT->env_proxy;
}

sub MyAgent::redirect_ok { 0 } # redirects should pass through

{                               ### MAIN ###
  use HTTP::Daemon;

  my $master = new HTTP::Daemon
    LocalAddr => $HOST, LocalPort => $PORT;
  warn "set your proxy to <URL:", $master->url, ">";
  my $slave;
  &handle_connection($slave) while $slave = $master->accept;
  exit 0;
}                               ### END MAIN ###

sub handle_connection {
  my $connection = shift;       # HTTP::Daemon::ClientConn

  # stephane: fork doesn't work correctly on Win32, removing the fork.
  # uncomment the 5 following lines if you are not using win32.

  #my $pid = fork;
  #if ($pid) {                   # spawn OK, and I'm the parent
  #  close $connection;
  #  return;
  #}
  ## spawn failed, or I'm a good child
  my $request = $connection->get_request;
  if (defined($request)) {
    my $response = &fetch_request($request);
    
    if (($request->header('Allow-Encoding') !~ /macros/i) and
    	($response->header('Content-Type') =~ /text\/.+ml/i)) {
    		$response->content(process_macros($response->content()));
    }
    
    $connection->send_response($response);
    close $connection;
  }
  #exit 0 if defined $pid;       # exit if I'm a good child with a good parent
}

sub fetch_request {
  my $request = shift;          # HTTP::Request

  use HTTP::Response;

  my $url = $request->url;
  warn "fetching $url";
  if ($url->scheme !~ /^(http|gopher|ftp)$/) {
    my $res = HTTP::Response->new(403, "Forbidden");
    $res->content("bad scheme: @{[$url->scheme]}\n");
    $res;
  } elsif (not $url->rel->netloc) {
    my $res = HTTP::Response->new(403, "Forbidden");
    $res->content("relative URL not permitted\n");
    $res;
  } else {
    &fetch_validated_request($request);
  }
}

sub fetch_validated_request { # return HTTP::Response
  my $request = shift;  # HTTP::Request

  ## uses global $AGENT

  ## warn "orig request: <<<", $request->headers_as_string, ">>>";
  $request->remove_header(qw(User-Agent From Referer Cookie));
  ## warn "anon request: <<<", $request->headers_as_string, ">>>";
  my $response = $AGENT->request($request);
  ## warn "orig response: <<<", $response->headers_as_string, ">>>";
  $response->remove_header(qw(Set-Cookie));
  ## warn "anon response: <<<", $response->headers_as_string, ">>>";
  $response;
}





# Copyright (c) 2002, Stephane Gigandet
# http://joueb.com/niutopia/ - biz@joueb.com
#
# Permission is hereby granted, free of charge, to any person 
# obtaining a copy of this software and associated documentation files
# (the "Software"), to deal in the Software without restriction, 
# including without limitation the rights to use, copy, modify, merge, 
# publish, distribute, sublicense, and/or sell copies of the Software, 
# and to permit persons to whom the Software is furnished to do so, 
# subject to the following conditions:
#
# The above copyright notice and this permission notice shall be 
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 
# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 
# ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 
# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 
# SOFTWARE.


# The following function process macros in a text document.

# Revisions:
#
# 02/17/02 - Stephane Gigandet - added detection of cycles in macros
#   to prevent infinite loops.
# 02/16/02 - Stephane Gigandet - initial implementation.


######################################################################
#
#	Function	process_macros($)
#
#	Input:		$html_ref
#
#	Output:		none
#
#	If the HTTP request contains an Accept-Encoding header that
#       lists the content-encoding "macro" as acceptable (without a
#	qvalue of 0), process_macros() returns the HTML unchanged.
#	Otherwise, it applies the following transformations to the HTML 
#	code passed in parameter.
#
#	- build an hash of macros from their declarations:
#	<define_macro name="some macro">
#	.. <arg name="some argument"> ..
#	..
#	</define_macro>
#
#	- remove the declarations of macros
#
#	- instantiate the macros wherever they are used:
#	<macro name="some macro"><arg name="some argument">..</macro>
#
######################################################################

sub process_macros($)
{
	# Retrieve parameter
	my $html = shift;
	
	# Transform line feeds into \\n so that . etc. can match them in regular
	# expressions (transformed back at the end of format_objects;
	$html =~s /\n/\\\\n/g ;
	
	# Check the Accept-Encoding header
	# TODO: tokenize the header, watch for macro;qvalue=0 or
	# identity with a higher qvalue.
	if (defined $ENV{'HTTP_ACCEPT_ENCODING'} and
		$ENV{'HTTP_ACCEPT_ENCODING'} =~ /macros/)
	{
		return $html;
	}
	
	my %macros;
	
	# recursively process the declarations and then the instantiations	
	$html = process_declarations($html, \%macros);
	
	# Put back line feeds
	$html =~ s/\\\\n/\n/g ;
	return $html;
}

sub process_declarations($$)
{
	my $html = shift;
	my $macros_ref = shift;
	
	# Find the first <define_macro name=".."> .. </define_macro>
	# (assumes <define_macro> can't be nested)
	if ($html =~ /<define_macro name=([^>]+)>(.*?)<\/define_macro>/ )
	{
		my $before_define_macro = $`;
		my $macro_name = $1;
		my $macro_value = $2;
		my $after_define_macro = $';
		
		clean_name(\$macro_name);
		
		return	process_instantiations($before_define_macro, $macros_ref, {}) .
			add_macro($macro_name, $macro_value, $macros_ref) .
			process_declarations($after_define_macro, $macros_ref);
	}
	else
	{
		return process_instantiations($html, $macros_ref, {});
	}
}

sub clean_name($)
{
	my $name_ref = shift;
	
	# Remove leading and trailing quotes
	$$name_ref =~ s/^"//;
	$$name_ref =~ s/"$//;
}

sub add_macro($$$)
{
	my $macro_name = shift;
	my $macro_value = shift;
	my $macros_ref = shift;
	
	# There can be <macro>s inside the declaration
	$macros_ref->{$macro_name} = process_instantiations($macro_value, $macros_ref, {});
	
	return "";
}

sub process_instantiations($$%)
{
	my $html = shift;
	my $macros_ref = shift;
	my $current_macros_ref = shift;
	my %current_macros = %$current_macros_ref;
	
	# Find first <macro name=".."> .. </macro>
	# Warning: <macro> can be nested. The following code will handle
	# only 4 levels of nesting.
	# TODO: enable infinite level of nesting.
	if ($html =~ /<macro name=([^>]*)>(.*?(<macro.*?(<macro.*?(<macro.*?<\/macro>.*?)<\/macro>.*?)*<\/macro>.*?)*)<\/macro>/ )
	{
		my $before_macro = $`;
		my $macro_name = $1;
		my $macro_arguments = $2;
		my $after_macro = $';
		
		clean_name(\$macro_name);
		
		my $instantiation;
		
		# Instantiate only if the macro has not already be called previously
		# and if the macros has been defined.
		
		if (	(! defined $current_macros{$macro_name}) &&
			(defined $macros_ref->{$macro_name}) )
		{
			# Add current macro the hash of current macros to avoid loop
			
			$current_macros{$macro_name} = 1;
			
			# Process instantiations inside the current macro arguments
			# (<macro> can be nested)
			$macro_arguments = process_instantiations($macro_arguments, 
				$macros_ref, {%current_macros});
			
			$instantiation = $macros_ref->{$macro_name} ;
			
			# Process arguments
			while ($macro_arguments =~ /<arg name=([^>]*)>(.*?)<\/arg>/)
			{
				my $argument_name = $1;
				my $argument_value = $2;
				$macro_arguments = $';
				
				clean_name(\$argument_name);
				
				# Replace argument with value
				$instantiation =~ s/<arg name="?$argument_name"?>/$argument_value/g;
			}			
		}
		
		return	$before_macro . 
			$instantiation . 
			process_instantiations($after_macro, $macros_ref, {%current_macros});
	}
	else 
	{
		return $html;
	}	
}
