perl-proxy: Немного юмора

В связи с работой над одним левым заказом мне пришлось заинтересоваться перлопроксями и вот, что из этого получилось:

#!/usr/bin/perl -Tw

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

my $VERSION_ID = q$Id: proxy,v 1.21 1998/xx/xx xx:xx:xx merlyn Exp $;
my $VERSION = (qw$Revision: 1.21 $ )[-1];

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

### debug management
sub prefix {
   my $now = localtime;
   join "", map { "[$now] [${$}] $_\n" } split /\n/, join "", @_;
}

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

&setup_signals();

### logging flags
my $LOG_PROC = 1;               # begin/end of processes
my $LOG_TRAN = 1;               # begin/end of each transaction
my $LOG_REQ_HEAD = 0;           # detailed header of each request
my $LOG_REQ_BODY = 0;           # header and body of each request
my $LOG_RES_HEAD = 0;           # detailed header of each response
my $LOG_RES_BODY = 0;           # header and body of each response

### configuration
my $HOST = 'WWW.XXX.YYY.ZZZ';
my $PORT = 3128;                   # pick next available user-port
my $SLAVE_COUNT = 8;            # how many slaves to fork
my $MAX_PER_SLAVE = 20;         # how many transactions per slave

### main
warn("running version ", $VERSION);

&main();
exit 0;

### subs
sub main {                      # return void
   use HTTP::Daemon;
   my %kids;

   my $master = HTTP::Daemon->new(LocalPort => $PORT, LocalAddr => $HOST) or die "Cannot create master: $!";
   warn("master is ", $master->url);
   ## fork the right number of children
   for (1..$SLAVE_COUNT) {
      $kids{&fork_a_slave($master)} = "slave";
   }
   {                             # forever:
      my $pid = wait;
      my $was = delete ($kids{$pid}) || "?unknown?";
      warn("child $pid ($was) terminated status $?") if $LOG_PROC;
      if ($was eq "slave") {      # oops, lost a slave
         sleep 1;                  # don't replace it right away
         #(avoid thrash)
         $kids{&fork_a_slave($master)} = "slave";
      }
   } continue { redo };          # semicolon for cperl-mode
}

sub setup_signals {             # return void
   setpgrp;                      # I *am* the leader
   $SIG{HUP} = $SIG{INT} = $SIG{TERM} = sub {
      my $sig = shift;
      $SIG{$sig} = 'IGNORE';
      kill $sig, 0;               # death to all-comers
      die "killed by $sig";
   };
}

sub fork_a_slave {              # return int (pid)
   my $master = shift;           # HTTP::Daemon

   my $pid;
   defined ($pid = fork) or die "Cannot fork: $!";
   &child_does($master) unless $pid;
   $pid;
}

sub child_does {                # return void
   my $master = shift;           # HTTP::Daemon
   my $did = 0;                  # processed count

   warn("child started") if $LOG_PROC;
   {
      flock($master, 2);          # LOCK_EX
      warn("child has lock") if $LOG_TRAN;
      my $slave = $master->accept or die "accept: $!";
      warn("child releasing lock") if $LOG_TRAN;
      flock($master, 8);          # LOCK_UN
      my @start_times = (times, time);
      $slave->autoflush(1);
      warn("connect from ", $slave->peerhost) if $LOG_TRAN;
      &handle_one_connection($slave); # closes $slave at right time
      if ($LOG_TRAN) {
         my @finish_times = (times, time);
         for (@finish_times) {
            $_ -= shift @start_times; # crude, but effective
         }
         warn(sprintf "times: %.2f %.2f %.2f %.2f %d\n", @finish_times);
      }
   } continue { redo if ++$did < $MAX_PER_SLAVE };
   warn("child terminating") if $LOG_PROC;
   exit 0;
}

sub handle_one_connection {     # return void
   use HTTP::Request;
   my $handle = shift;           # HTTP::Daemon::ClientConn

   my $request = $handle->get_request;
   print $request;
   defined($request) or die "bad request"; # XXX

   my $response = &fetch_request($request);
   warn("response: <<<\n", $response->headers_as_string, "\n>>>")
   if $LOG_RES_HEAD and not $LOG_RES_BODY;
   warn("response: <<<\n", $response->as_string, "\n>>>")
   if $LOG_RES_BODY;
   $handle->send_response($response);
   close $handle;
}

sub fetch_request {             # return HTTP::Response
   use HTTP::Response;
   use URI::URL;
   my $request = shift;          # HTTP::Request

   ## XXX
   print "Request was: " . $request->as_string;
   ## XXXX needs policy here
   my $url = URI::URL->new($request->url);

   if ($url->scheme !~ /^(https?|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 {
      ## validated request, get it!
      warn("processing url is $url") if $LOG_TRAN;
      &fetch_validated_request($request);
   }
}

BEGIN {                         # local static block
   my $agent;                    # LWP::UserAgent

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

   $agent ||= do {
      use LWP::UserAgent;
      my $agent = LWP::UserAgent->new;
      $agent->agent("proxy/$VERSION " . $agent->agent);
      $agent->env_proxy;
      $agent;
   };

   warn("fetch: <<<\n", $request->headers_as_string, "\n>>>")
   if $LOG_REQ_HEAD and not $LOG_REQ_BODY;
   warn("fetch: <<<\n", $request->as_string, "\n>>>")
   if $LOG_REQ_BODY;

   my $response = $agent->simple_request($request);

   if ($response->is_success and $response->content_type =~ /text\/(plain|html)/ and not ($response->content_encoding || "") =~ /\S/ and ($request->header("accept-encoding") || "") =~ /gzip/) {
      require Compress::Zlib;
      my $content = $response->content;
      my $new_content = Compress::Zlib::memGzip($content);
      if (defined $new_content) {
         $response->content($new_content);
         $response->content_length(length $new_content);
         $response->content_encoding("gzip");
         warn("gzipping content from " . (length $content) . " to " . (length $new_content)) if $LOG_TRAN;
      }
   }

   $response;
}
}

Немного разоблачений:

1. Код не мой, как видно по копирайту - я лишь подправил кое-что в области URI::URL, чтоб оно работало и добавил print $request->as_string для отладки.
2. Переменную $HOST устанавливаем в адрес хоста, на котором крутится прокси, а $PORT присваиваем номер порта, который слушает наш прокси.
3. Настраиваем клиент на использование прокси - указываем адрес хоста и порт $HOST:$PORT
4. Скрипт при запуске плодит pre-forked потомков, которые слушают порт $PORT
5. При поступлении запроса на соединение на указанный порт с помощью манипуляций объектами HTTP::Request, HTTP::Response и LWP::UserAgent перебрасываем запрос на сервер-рецепиент.

Вот так вкратце. А впрочем, из кода довольно прозрачно всё видно. Всё гениальное просто :) Можно запустить эту игрушку и шарить т.о. одно dial-up соединение для доступа к web (чем я сейчас и занимаюсь), не трогая NAT.