Форум на Исходниках.RU

#!/home/merlyn/bin/perl -Tw

use strict;

$ENV{PATH} = join ":", qw(/usr/ucb /bin /usr/bin);

$|++;

## 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

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

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);

$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 {

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;

}